application.filesearch replacement for 2007

[jkomorowski]

Hi, I am fairly new to macro writing and am having trouble converting an old macro that I had working for 2003, but that wont work for 2007. I have searched the internet and found numerous other postings on replacing application.filesearch, but I can't seem to get any of them working for me.

I am trying to search a folder that is selected by the user for all .jpg files, and then place all those pictures onto a certain spreadsheet within the excel file. It also formats the pictures. Following is the code:

   Private Sub BatchProcessThumb2x3()
    Msg = "Select a file containing the photos you want to insert."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
 
    On Error Resume Next
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        .Filename = "*.jpg"
        .SearchSubFolders = False
        .Execute
 
'   Select begining range
    Worksheets("Thumbnail (2x3)").Select
    Range("B4").Select
'   Loop through all files and process them
 
        For i = 1 To .FoundFiles.Count
            Application.StatusBar = "Processing " & .FoundFiles(i)
'   Import and insert the photo
            ActiveSheet.Pictures.Insert(.FoundFiles(i)).Select
            Selection.ShapeRange.LockAspectRatio = msoTrue
            Selection.ShapeRange.Width = 225#
 
            If Int(i / 2) - (i / 2) <> 0 Then _
                ColOff = 3 Else ColOff = -3
            If Int(i / 2) - (i / 2) <> 0 Then _
                RowOff = 0 Else RowOff = 4
            ActiveCell.Offset(RowOff, ColOff).Select
        Next i
            Application.StatusBar = False
    End With
End Sub

Any and all help would be greatly appreciated.

Thanks, Jason

 

[jkomorowski]

Not a problem, I will figure it out. Thanks again for all of your help. You are awesome!!!!!!!!! You saved me big time!

 

[jkomorowski]

Does anyone else know why this may be happening? When I step through it, the correct cell is active, but then when it places the picture it places it in the original cell B4. Here is the code that I have working thus far.

 Private Sub BatchProcessThumb2x3()
    Msg = "Select a file containing the photos you want to insert."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
 
    
    fn = Dir(Directory & "\*jpg")
    Range("B4").Select
    Do While fn <> ""
        i = i + 1
        Application.StatusBar = "Processing " & fn
        ActiveSheet.Pictures.Insert(Directory & "\" & fn).Select
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.Width = 225#
            If Int(i / 2) - (i / 2) <> 0 Then _
                ColOff = 3 Else ColOff = -3
            If Int(i / 2) - (i / 2) <> 0 Then _
                RowOff = 0 Else RowOff = 4
            ActiveCell.Offset(RowOff, ColOff).Select
            fn = Dir()
    Loop
            Application.StatusBar = False
End Sub

Thanks,
Jason

 

[jindon]

Just try and see how it goes.

 Private Sub BatchProcessThumb2x3()
    Msg = "Select a file containing the photos you want to insert."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
 
    
    fn = Dir(Directory & "\*jpg")
    Set myRng = Range("B4")
    Do While fn <> ""
        i = i + 1
        Application.StatusBar = "Processing " & fn
        myRng.Select
        ActiveSheet.Pictures.Insert(Directory & "\" & fn).Select
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.Width = 225#
            If i Mod 2 <> 0 Then
                ColOff = 3 : RowOff = 0
            Else 
                ColOff = -3 : RowOff = 4
            End If
            Set myRng = myRng.Offset(RowOff, ColOff)
            fn = Dir()
    Loop
            Application.StatusBar = False
End Sub

 

[jkomorowski]

I tried your fix, but it still just places all the photos in B4. I found the following link which seems to be address the issue. I am having trouble implementing it though.

http://www.developersdex.com/vb/message.asp?p=2677&ID=%3CF0196413-2C57-4B3F-8A5B-0630B739276D%40microsoft.com%3E