各位大虾帮帮偶

Question

偶是一位VB新手，现要实现如下一个功能
根据数据库中的一个字段，把对应文件夹内的图片挑出来放到另一个文件夹中，并把数据库中存在，但文件夹内不存在的图片的记录写到一个文本文件中，该功能已基本实现Private Sub Command1_Click()
    
   Dim fso As New FileSystemObject
      
      If Dir("d:\ks_photo", vbDirectory) <> "" Then
            MsgBox "文件夹：d:\ks_photo 已存在！您想再执行一次吧"
           fso.DeleteFolder ("d:\ks_photo") ' 删除原来的文件夹
           fso.DeleteFile ("d:\nophoto.txt") '删除原来的nophoto文件
           fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
      Else
           fso.CreateFolder ("d:\ks_photo") ' 新建一个文件夹
      End If
   
   Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, filePath As String
    cn.CursorLocation = adUseClient
    cn.Open "Driver={Microsoft dBASE Driver (*.dbf)}; DriverID=277;Dbq=d:\"    rs.Open "select * from 22222.dbf ", cn, adOpenKeyset, adLockOptimistic
        
    While Not rs.EOF
        filePath = "z:\" & rs(3) & ".jpg"
        If Dir(filePath) <> "" Then ' 找到相对应的相片
            FileCopy filePath, "D:\ks_photo\" & rs(3) & ".jpg"  '拷贝文件
        Else
            Open "D:\nophoto.txt" For Append As #1 '生成txt文件
                Write #1, rs(0), rs(1), rs(2), rs(3), rs(4)
            Close 1
        End If
        rs.MoveNext
    Wend
  
  MsgBox "程序已执行完毕喽！"
 
End Sub
现要增加一功能，现在图片是存放于一个文件夹内的，怎么样才能对其下面所属的子文件夹进行遍历，谢谢

Answer 1

Function SearchFiles(ByVal BasePath As String, Optional ByVal searchPattern As String = "*.*") As Collection
    Dim colPathStack As Collection, colFiles As Collection
    Dim sPath As String, sFound As String
    Set colFiles = New Collection
    Set colPathStack = New Collection
    colPathStack.Add BasePath & IIf(Right$(BasePath, 1) <> "\", "\", vbNullString)
    While colPathStack.Count <> 0
        sPath = colPathStack(1)
        colPathStack.Remove 1        sFound = Dir(sPath & "*.*", vbDirectory + vbHidden)
        While LenB(sFound)
            If (sFound <> ".") And (sFound <> "..") Then
                If (GetAttr(sPath & sFound) And vbDirectory) <> 0 Then
                    colPathStack.Add sPath & sFound & "\"
                End If
            End If
            sFound = Dir()
        Wend        sFound = Dir(sPath & searchPattern, vbHidden)
        While LenB(sFound)
            colFiles.Add sPath & sFound
            Debug.Print sPath & sFound
            
            sFound = Dir()
        Wend
    Wend    Set SearchFiles = colFiles
End Function