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
|