VBA Wildcard search for image based on a cell

[shophoney]

Hi, below is my code I use to look up products for an image. It looks in a folder for the correct photo. But we would like to now separate all the photos into sub folders, based on class.

Is there a way to modify my code to look into sub folders for the image.jpg

Private Sub Worksheet_Change(ByVal Target As Range)

Sheets("TOPn").Select
ActiveSheet.Unprotect
Rows("7:7").Select
ActiveWindow.SmallScroll Down:=462
Rows("7:499").Select
Selection.RowHeight = 100
Sheets("TOPn").Select
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowUsingPivotTables:=True

'Sub Products_Click()
Application.ScreenUpdating = False
Dim myObj
Dim Pictur
Set myObj = ActiveSheet.DrawingObjects
For Each Pictur In myObj
If Left(Pictur.Name, 7) = "Picture" Then
Pictur.Select
Pictur.Delete
End If
Next

Dim EmployeeName As String, T1 As String

'*****PHOTO 1
myDir = "U:\Pictures\Products"
EmployeeName = Range("D7")
T1 = ".jpg"

On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & EmployeeName & T1, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=1105, Top:=200, width:=100, height:=100

errormessage:
If Err.Number = 1004 Then
'MsgBox "File does not exist." & vbCrLf & "Check the model! (D7)"
'Range("A2").Value = ""
'Range("B2").Value = ""

End If

'Run next photo
Call cmdDisplayPhoto_2_Click
Call cmdDisplayPhoto_3_Click
Call cmdDisplayPhoto_4_Click
Call cmdDisplayPhoto_5_Click
Call cmdDisplayPhoto_6_Click
Call cmdDisplayPhoto_7_Click
Call cmdDisplayPhoto_8_Click
Call cmdDisplayPhoto_9_Click
Call cmdDisplayPhoto_10_Click
Call cmdDisplayPhoto_11_Click
Call cmdDisplayPhoto_12_Click
Call cmdDisplayPhoto_13_Click
Call cmdDisplayPhoto_14_Click
Call cmdDisplayPhoto_15_Click
Call cmdDisplayPhoto_16_Click
Call cmdDisplayPhoto_17_Click
Call cmdDisplayPhoto_18_Click
Call cmdDisplayPhoto_19_Click
Call cmdDisplayPhoto_20_Click
Call cmdDisplayPhoto_21_Click
Call cmdDisplayPhoto_22_Click
Call cmdDisplayPhoto_23_Click
Call cmdDisplayPhoto_24_Click
Call cmdDisplayPhoto_25_Click
Call cmdDisplayPhoto_26_Click
Call cmdDisplayPhoto_27_Click
Call cmdDisplayPhoto_28_Click
Call cmdDisplayPhoto_29_Click

End Sub

 

[Worf]

The example below lists all files from all sub folders and filters the list to show only the desired image. Run the image path routine.

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type


Sub ImagePath()
Dim Msg As String, Directory$, ename$
Msg = "Select the folder for the recursive directory listing."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
Sheets("sheet1").Activate                                               ' where list goes
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
If MsgBox("Clear contents of active sheet?", vbYesNo) = vbNo Then Exit Sub
Cells.ClearContents
RecursiveDir (Directory)                                                ' list all files
ename = Sheets("sheet2").[d7]                                           ' image name
[b:b].AutoFilter
[b:b].AutoFilter 1, "=" & ename & ".jpg", xlAnd                         ' show only that image
End Sub


Public Sub RecursiveDir(ByVal CurrDir$)
Dim Dirs() As String, NumDirs As Long, FileName As String, PathAndName$, i&
If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "Size"
Cells(1, 4) = "Date/Time"
Range("A1:D1").Font.Bold = True
FileName = Dir(CurrDir & "*.*", vbDirectory)
Do While Len(FileName) <> 0
  If Left(FileName, 1) <> "." Then 'Current dir
    PathAndName = CurrDir & FileName
    If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
      'store found directories
       ReDim Preserve Dirs(0 To NumDirs) As String
       Dirs(NumDirs) = PathAndName
       NumDirs = NumDirs + 1
    Else
      Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
      Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
      Cells(WorksheetFunction.CountA(Range("C:C")) + 1, 3) = FileLen(PathAndName)
      Cells(WorksheetFunction.CountA([d:d]) + 1, 4) = FileDateTime(PathAndName)
    End If
End If
    FileName = Dir()
Loop
For i = 0 To NumDirs - 1
    RecursiveDir Dirs(i)
Next
End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO, path As String, r As Long, x As Long, pos%
    bInfo.pidlRoot = 0& ' root folder is desktop
' 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

 

[shophoney]

Hi thanks for the response.

How would I be able to apply that to my current code that looks for a specific file name based on a cell.jpg

It's quite different that what I already use. Can they be combined.

 

[Worf]

Like this:

' sheet module
Private Sub CommandButton1_Click()
ImagePath
Me.Shapes.AddPicture f, msoFalse, msoTrue, 105, 200, 100, 100
End Sub

' standard module
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl&, ByVal pszPath$) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Public f$
 
Sub ImagePath()
Dim Msg$, drt$
drt = "c:\accounts"                         ' root
If Right(drt, 1) <> "\" Then drt = drt & "\"
RecursiveDir (drt)                          ' list all files
End Sub


Public Sub RecursiveDir(ByVal CurrDir$)
Dim Dirs() As String, NumDirs As Long, fn$, PathAndName$, i&
If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"
fn = Dir(CurrDir & "*.*", vbDirectory)
Do While Len(fn) <> 0
  If Left(fn, 1) <> "." Then 'Current dir
    PathAndName = CurrDir & fn
    If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
       ReDim Preserve Dirs(0 To NumDirs) As String
       Dirs(NumDirs) = PathAndName
       NumDirs = NumDirs + 1
    Else
        If fn = Sheets("sheet2").[d7] & ".jpg" Then f = CurrDir & fn    ' the file
    End If
End If
    fn = Dir()
Loop
For i = 0 To NumDirs - 1
    RecursiveDir Dirs(i)
Next
End Sub