VBA検索フォルダとサブフォルダにアクセスしてテーブルに結果を追加します

Question

私はAccess 2013を使用していて、渡されたフォルダパス内のすべての画像を検索する小さなプログラムを持っています。次に、これらのパスのそれぞれを「tblImages」という表に追加します。唯一の問題は、各フォルダ\ subフォルダ内の最初の画像、つまり各フォルダの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です。