Microsoft Excel - Search Folders for pictures and insert

Asked By Jason on 09-Jun-11 11:08 AM

So my problem is that I am able to search for pictures right now but only in a specified folder.  I was wondering if it was possible to search a folder and its subfolders.  Here is the code i have so far.

Sub Picture2()
 jason = InputBox("Enter the path of the folder that the pictures are stored in")
 Dim picname As String
 
 Dim pasteAt As Integer
 Dim lThisRow As Long

   
    lThisRow = 2

    Do While (Cells(lThisRow, 3) <> "")
  
      pasteAt = lThisRow
      Cells(pasteAt, 1).Select     
      'Dim picname As String
     picname = Cells(lThisRow, 3) 
      On Error Resume Next
     
    
 
      ActiveSheet.Pictures.Insert("Jason" & picname & ".jpg").Select 
      With Selection
        '.Left = Range("A6").Left
        '.Top = Range("A6").Top
        .Left = Cells(pasteAt, 1).Left
        .Top = Cells(pasteAt, 1).Top
       
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100#
        .ShapeRange.Width = 80#
        .ShapeRange.Rotation = 0#
      End With
     
      lThisRow = lThisRow + 1
   
    Loop
   
    Range("A10").Select
    Application.ScreenUpdating = True
   

End Sub

Riley K replied to Jason on 09-Jun-11 12:02 PM
Try using this below function, it can also filter for specific files

Option Explicit
Sub SrchForFiles() ' Searches the selected folders and sub folders for files with the specified 'extension. .xls, .doc, .ppt, etc. 'A new worksheet is produced called "File Search Results". You can click on the link and go directly 'to the file you need. Dim i As Long, z As Long, Rw As Long Dim ws As Worksheet Dim y As Variant Dim fLdr As String, Fil As String, FPath As String y = Application.InputBox("Please Enter File Extension", "Info Request") If y = False And Not TypeName(y) = "String" Then Exit Sub Application.ScreenUpdating = False '********************************************************************** 'fLdr = BrowseForFolderShell With Application.FileDialog(msoFileDialogFolderPicker) .Show fLdr = .SelectedItems(1) End With '********************************************************************** With Application.FileSearch .NewSearch .LookIn = fLdr .SearchSubFolders = True .Filename = y Set ws = ThisWorkbook.Worksheets.Add(Sheets(1)) On Error Goto 1 2: ws.Name = "FileSearch Results" On Error Goto 0 If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Fil = .FoundFiles(i) 'Get file path from file name FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1) If Left$(Fil, 1) = Left$(fLdr, 1) Then If CBool(Len(Dir(Fil))) Then z = z + 1 ws.Cells(z + 1, 1).Resize(, 4) = _ Array(Dir(Fil), _ FileLen(Fil) / 1000, _ FileDateTime(Fil), _ FPath) ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _ Address:=.FoundFiles(i) End If End If Next i End If End With ActiveWindow.DisplayHeadings = False With ws Rw = .Cells.Rows.Count With .[A1:D1] .Value = [{"Full Name","Kilobytes","Last Modified", "Path"}] .Font.Underline = xlUnderlineStyleSingle .EntireColumn.AutoFit .HorizontalAlignment = xlCenter End With .[E1:IV1 ].EntireColumn.Hidden = True On Error Resume Next Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo End With Application.ScreenUpdating = True Exit Sub 1: Application.DisplayAlerts = False Worksheets("FileSearch Results").Delete Application.DisplayAlerts = True Goto 2 End Sub
Jason replied to Riley K on 09-Jun-11 12:14 PM
What I need is to insert pictures based on a list of numbers in column C.  I need the pictures to populate in column A on the same row.  I've started modifying your code a little but I am getting very lost.  I really appreciate your help.
Jason replied to Riley K on 09-Jun-11 12:26 PM
Here is what I have changed.  Not really sure where to go from here.


Sub SrchForFiles()
   ' Searches the selected folders and sub folders for files with the specified
   'extension.  .xls, .doc, .ppt, etc.
   'A new worksheet is produced called "File Search Results".  You can click on the link and go directly
   'to the file you need.
    Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, Fil As String, FPath As String
    Dim picname As String
    Dim pasteAt As Integer
    Dim lThisRow As Long
   
      lThisRow = 2

    Do While (Cells(lThisRow, 3) <> "")
   
    pasteAt = lThisRow
      Cells(pasteAt, 1).Select
      picname = Cells(lThisRow, 3)
      On Error Resume Next
     
    Application.ScreenUpdating = False

    With Application.FileSearch
      .NewSearch
      .LookIn = "J:\Int'l Growth Strategy\IGS Images\Portal-Ready\"
      .SearchSubFolders = True
      .Filename = picname & "*" & ".jpg"
      On Error GoTo 1
2:
      On Error GoTo 0
      If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
          Fil = .FoundFiles(i)
         'Get file path from file name
          FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
          If Left$(Fil, 1) = Left$(fLdr, 1) Then
            If CBool(Len(Dir(Fil))) Then
              z = z + 1
              ws.Cells(z + 1, 1).Resize(, 4) = _
              Array(Dir(Fil), _
              FileLen(Fil) / 1000, _
              FileDateTime(Fil), _
              FPath)
              ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
              Address:=.FoundFiles(i)
            End If
          End If
        Next i
      End If
    End With
  
    ActiveWindow.DisplayHeadings = False
  
    With ws
      Rw = .Cells.Rows.Count
      With .[A1:D1]
        .Value = [{"Full Name","Kilobytes","Last Modified", "Path"}]
        .Font.Underline = xlUnderlineStyleSingle
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
      End With
      .[E1:IV1 ].EntireColumn.Hidden = True
      On Error Resume Next
      Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
      Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
    End With
         lThisRow = lThisRow + 1
   
    Loop
   
    Application.ScreenUpdating = True
    Exit Sub
1:      Application.DisplayAlerts = False
    Worksheets("FileSearch Results").Delete
    Application.DisplayAlerts = True
    GoTo 2
   

End Sub

wally eye replied to Jason on 09-Jun-11 07:26 PM

It looks like you are specifying the name of the picture, would you rather just have it find all the .jpg files and paste them in, then update the path in column c?

Try this:

Public Sub StartImport()
  
  Dim wksCurr       As Worksheet
  
  Dim lngLastRow      As Long
  
  Set wksCurr = ActiveSheet 
  lngLastRow = wksCurr.Columns(3).Find(what:="*", After:=[C1], _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
  If lngLastRow > 2 Then
    wksCurr.Rows(3).Resize(lngLastRow - 2).Delete
  End If
  
  Call GetPictures("c:\documents and settings\wallyeye\My Documents")
  
End Sub
  
Public Sub GetPictures(ByVal strPathName As String)
  
On Error GoTo Proc_Error
  
'MUST set reference to Windows Script Host Object Model in the project to use this code!
  
  Dim objFS         As FileSystemObject
  Dim objFolder       As Folder
  Dim objFolderSub      As Folder
  Dim objFile       As File
  Dim wksCurr       As Worksheet
  Dim wbkWork       As Workbook
  
  Dim lngLastRow      As Long
  
  Set objFS = New FileSystemObject
  If strPathName = "" Then
    MsgBox "Please enter the path to the folders", vbOKOnly
  End If
  Set objFolder = objFS.GetFolder(strPathName)
'
'  Find the first available row for new data
'
  Set wksCurr = ActiveSheet
  lngLastRow = wksCurr.Columns(3).Find(what:="*", After:=[C1], _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
  
  For Each objFile In objFolder.Files
    If Right(objFile.Name, 3) = "jpg" Then
      ActiveSheet.Pictures.Insert(objFile.Path).Select
      lngLastRow = lngLastRow + 1
      With Selection
        .Left = Cells(lngLastRow, 1).Left
        .Top = Cells(lngLastRow, 1).Top
  
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100#
        .ShapeRange.Width = 80#
        .ShapeRange.Rotation = 0#
      End With
      ActiveSheet.Cells(lngLastRow, 3) = objFile.Path
    End If
  Next objFile
'
'  Read through each subfolder from the path of current spreadsheet
'
  For Each objFolderSub In objFolder.SubFolders
    Call GetPictures(objFolderSub.Path)
  Next objFolderSub
  
Proc_Exit:
  
  Set wksWork = Nothing
  Set wksCurr = Nothing
  
  Set objFile = Nothing
  Set objFolderSub = Nothing
  Set objFolder = Nothing
  Set objFS = Nothing
  
  Exit Sub
  
Proc_Error:
    
  Select Case Err
    Case Else
      MsgBox "Error " & CStr(Err) & ": " & Err.Description
      Resume Proc_Exit
  End Select

You will need to set a reference to the Windows Script Host Object Model in the VBA IDE (Tools, References, then scroll down to find it), and change the path in the StartImport routine to your own path.

Jason replied to Jason on 10-Jun-11 09:32 AM
No I have a folder with hundreds of subfolders that contain thousand of pictures.  And I have a list of picture names in various spreadsheets.  My goal is to have the list of picture names in column C and use VBA to pull the pictures and place them in column A.  I can do this if all the pictures are in one folder but I can't figure it out when there is sub folders.
Kirtan Patel replied to Jason on 11-Jun-11 02:47 AM
Sub FileSearch()
 
'set current directory as the one to search
  CurrentDirectory = "Z:\Singapore\Singapore Turf\Singapore Turf Club 2\QEII Cup 2006\QEII Cup 2006_VD\Millenium Copthorne International\TVGI Race Name Text\"
  CurrentDirectory = "Z:\Singapore\Singapore Turf\Singapore Turf Club 2\QEII Cup 2006\QEII Cup 2006_VD\Millenium Copthorne International\TVGI Race Name Logo\"
'look in current directory and count the number of jpg files
  With Application.FileSearch
    .LookIn = CurrentDirectory
    .Filename = "*.jpg"
    .SearchSubFolders = False
     
  If .Execute() > 0 Then
 
  Randomize
 
    MessageText = "There were " & .FoundFiles.Count & " file(s) found."
    Choice = MsgBox(MessageText, vbOKCancel)
    If Choice = vbCancel Then GoTo leave
 
     ' For i = 1 To .FoundFiles.Count
      rndValue = Int((.FoundFiles.Count * Rnd) + 1)
      Call InsertPictureInRange(.FoundFiles(rndValue), Range("B5:D10"))
      Call InsertPictureInRange(.FoundFiles(rndValue), Range("J7:L11"))
     '   MsgBox .FoundFiles(i)
     ' Next i
    MessageText = "There were " & .FoundFiles.Count & " file(s) found."
    Choice = MsgBox(MessageText, vbOKCancel)
    If Choice = vbCancel Then GoTo leave
 
    For i = 1 To .FoundFiles.Count
      Call TestInsertPictureInRange
      MsgBox .FoundFiles(i)
    Next i
     
  Else
    MsgBox "There were no files found.", vbCritical
  End If
End With
leave:
End Sub
 
Sub TestInsertPictureInRange()
  InsertPictureInRange "Z:\Singapore\Singapore Turf\Singapore Turf Club 2\QEII Cup 2006\QEII Cup 2006_VD\Millenium Copthorne International\TVGI Race Name Text\", _
  Range("B5:D10")
  InsertPictureInRange "Z:\Singapore\Singapore Turf\Singapore Turf Club 2\QEII Cup 2006\QEII Cup 2006_VD\Millenium Copthorne International\TVGI Race Name Logo\", _
  Range("J7:L11")
End Sub
  
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
   ' inserts a picture and resizes it to fit the TargetCells range
  Dim p As Object, t As Double, l As Double, w As Double, h As Double
  If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
  If Dir(PictureFileName) = "" Then Exit Sub
   ' import picture
  Set p = ActiveSheet.Pictures.Insert(PictureFileName)
   ' determine positions
  With TargetCells
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
  End With
   ' position picture
  With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
  End With
  Set p = Nothing
End Sub
Jackpot . replied to Jason on 11-Jun-11 05:33 AM
Hi Jason

Create a new module and copy the below code. Try and feedback..

--The below would prompt the user to select a folder
--Search for the filenames mentioned in Column C..(I assume the file names do not have the extension) in the selected folder and its subfolders
--Insert those to colA




Dim strFilePath As String
Sub Picture2()
   
Dim strPath As String, sh As Object, lngRow As Long
   
'Folder Selection
With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "C:\"
  .AllowMultiSelect = False
  .Show
  If .SelectedItems.Count <> 0 Then
  strPath = .SelectedItems(1)
  Else
  Exit Sub
  End If
End With
  
  
Application.ScreenUpdating = False
For lngRow = 2 To Cells(Rows.Count, "C").End(xlUp).Row
Call GetFilePath(strPath, Range("C" & lngRow).Text)
If strFilePath <> "" Then
  Set sh = ActiveSheet.Pictures.Insert(strFilePath)
  With sh
    .Left = Cells(lngRow, 1).Left
    .Top = Cells(lngRow, 1).Top
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 100#
    .ShapeRange.Width = 80#
    .ShapeRange.Rotation = 0#
  End With
  strFilePath = ""
End If
Next
Application.ScreenUpdating = True
    
  
End Sub
  
Sub GetFilePath(strPath As String, strFileName As String)
Dim fso As Object, fsofolder As Object, fsoSFolder As Object, fsoFile As Object
Dim strFolder As String, strFile As String
  
If strFilePath <> "" Then Exit Sub
strFilePath = ""
  
Set fso = CreateObject("Scripting.FileSystemObject")
  
Set fsofolder = fso.GetFolder(strPath)
For Each fsoFile In fsofolder.Files
If StrComp(fsoFile.Name, strFileName & ".jpg", vbTextCompare) = 0 Then
strFilePath = strPath & "\" & fsoFile.Name: Exit Sub
End If
Next
  
For Each fsoSFolder In fsofolder.SubFolders
If fsoSFolder.Attributes = 2064 Then
Call GetFilePath(fso.GetAbsolutePathName(fsoSFolder), strFileName)
End If
Next
  
End Sub