Доступ к папкам поиска и подпапкам VBA и добавление результатов в таблицу

Question

Я использую Access 2013 и имею небольшую программу для поиска всех изображений в пути к папке, который передается ему. Затем он добавляет каждый из этих путей в таблицу под названием «tblImages». Единственная проблема заключается в том, что он только когда-либо возвращает первое изображение в каждой папке \ sub folder i.e. 1 изображение из каждой папки и игнорирует остальные. Как изменить его для поиска и добавления каждого изображения в каждую папку \ sub?

Public Sub listImages(folderPath As String) 
    'define variables 
    Dim fso As Object 
    Dim objFolder As Object 
    Dim objFolders As Object 
    Dim objF As Object 
    Dim objFile As Object 
    Dim objFiles As Object 
    Dim strFileName As String 
    Dim strFilePath As String 
    Dim myList As String 
    Dim rst As DAO.Recordset 

    'set file system object 
    Set fso = CreateObject("Scripting.FileSystemObject") 

    'set folder object 
    Set objFolder = fso.GetFolder(folderPath) 

    'set files 
    Set objFiles = objFolder.files 
    Set objFolders = objFolder.subfolders 


    'list all images in folder 
    For Each objFile In objFiles 

     If Right(objFile.Name, 4) = ".jpg" Then 
      strFileName = objFile.Name 
      strFilePath = objFile.path 
      myList = myList & strFileName & " - " & strFilePath & vbNewLine 
     End If 


    Next 

    'go through all subflders 
    For Each objF In objFolders 


     'call same procedure for each subfolder 
     Call listImages(objF.path) 


    Next 

      Set rst = CurrentDb.OpenRecordset("tblImages", dbOpenDynaset, dbSeeChanges) 
      With rst 
      .AddNew 
      .Fields("Image") = strFileName 
      .Fields("FilePath") = strFilePath 
      .Update 
     End With 

    'Debug.Print myList 

    Set objFolder = Nothing 
    Set objFolders = Nothing 
    Set objFile = Nothing 
    Set objF = Nothing 
    Set fso = Nothing 
End Sub 

Answer 1

Вы были очень близки. Вы можете поместить это в модуль класса с именем FileSearch

Option Compare Database 
Option Explicit 

Private fso As FileSystemObject 

Public ExtensionFilters As Dictionary 

Private Sub Class_Initialize() 
Set fso = New FileSystemObject 
End Sub 

Public Sub listImages(folderPath As String) 
    'define variables 
    Dim objFolder As Folder 
    Dim objFolders As Folders 
    Dim objF As Folder 
    Dim objFile As File 
    Dim objFiles As Files 
    Dim strFileName As String 
    Dim strFilePath As String 
    Dim myList As String 
    Dim rst As DAO.Recordset 

    If Not fso.FolderExists(folderPath) Then Exit Sub 
    'set folder object 
    Set objFolder = fso.GetFolder(folderPath) 

    'set files 
    Set objFiles = objFolder.Files 
    Set objFolders = objFolder.SubFolders 

    'list all images in folder 
    For Each objFile In objFiles 
     If Not ExtensionFilters Is Nothing Then 
      If ExtensionFilters.Exists(fso.GetExtensionName(objFile.path)) Then 
       strFileName = objFile.Name 
       strFilePath = objFile.path 
       AddImageToTable strFileName, strFilePath 
      End If 
     End If 
    Next 

    'go through all subflders 
    For Each objF In objFolders 
     'call same procedure for each subfolder 
     Call listImages(objF.path) 
    Next 

End Sub 

Private Sub AddImageToTable(strFileName, strFilePath) 
    Debug.Print strFileName, strFilePath 
' change as needed 
'  Set rst = CurrentDb.OpenRecordset("tblImages", dbOpenDynaset, dbSeeChanges) 
'   With rst 
'   .AddNew 
'   .Fields("Image") = strFileName 
'   .Fields("FilePath") = strFilePath 
'   .Update 
'  End With 
End Sub 

и назвать его, как это, где бы

Dim fs As New FileSearch 
Dim ExtensionFilters As New Dictionary 
ExtensionFilters.Add "jpg", "jpg" 
ExtensionFilters.Add "jpeg", "jpeg" 

Set fs.ExtensionFilters = ExtensionFilters 
fs.listImages "C:\Users\bradley_handziuk\Downloads" 

Также актуальным является DIR function.