View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
John[_143_] John[_143_] is offline
external usenet poster
 
Posts: 13
Default Using 32 bit VBA in Excel 2007



I made the rash assumption that the 32 bit call was the problem. My project
is generating a sheet of 24 photo thumbnails along with their "name" on a
worksheet. All photos are stored in files grouped in 24. The eventual print
sheet is then placed in a hard copy folder which allows for quick retrieval.
Has worked like a charm for 8-9 years. I "stepped" the code and it appears
to locate the first entry point on the worksheet, but does not insert the
photo. It then stops. The code(s) are listed below:
This code is from J Walks PUP:
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


' Macro recorded 7/28/00 by John Eppley

Sub DigitalThumbnails()
Msg = "Select a location containing the Photos you want to print."
directory = GetDirectory(Msg)
If directory = "" Then Exit Sub
If Right(directory, 1) < "\" Then directory = directory & "\"

Application.ScreenUpdating = False
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = directory
.Filename = "*.*"
.SearchSubFolders = False
.Execute
i = 1

Set mydir = Range("j1")
mydir.FormulaR1C1 = directory
'mydir.FormulaR1C1 = Left(mydir, Len(mydir) - 1)
'mydir.FormulaR1C1 = Mid(mydir, Find("\", mydir, 4) + 1, 24)
'CopyFolderName

For x = 3 To 13 Step 2
For y = 1 To 7 Step 2

ActiveSheet.Cells(x, y).Select
ActiveSheet.Pictures.Insert(.FoundFiles(i)).Select
Selection.ShapeRange.Height = ActiveCell.RowHeight
ActiveCell.Offset(1, 0).Select
ActiveCell.Formula = Right(.FoundFiles(i), 12)
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = FileDateTime(.FoundFiles(i))
If .FoundFiles(i) = "" Then Exit Sub
i = i + 1
Next
Next

End With
End Sub