各位大虾帮我一把，谢谢了

Question

我现在做了一个功能，就是根据数据库中的字段，将对应文件夹内的图片复制到另一个文件夹内，并把数据库中存在，但文件夹内不存在的图片的记录写到一个文本文件中，该功能已基本实现 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 zk.dbf ", cn, adOpenKeyset, adLockOptimistic
        
    While Not rs.EOF
        filePath = "z:\photo\" & rs(6) & ".jpg"
        If Dir(filePath) <> "" Then ' 找到相对应的相片
            FileCopy filePath, "D:\ks_photo\" & rs(6) & ".jpg"  '拷贝文件
        Else
            Open "D:\nophoto.txt" For Append As #1 '生成txt文件
                Write #1, rs(0), rs(1), rs(2), rs(3), rs(4), rs(5), rs(6)
            Close 1
        End If
        rs.MoveNext
    Wend
  
  MsgBox "程序已执行完毕喽！"
 
End Sub现要增加一功能，现在图片是存放于一个文件夹内（z:\photo）的，如果这些图片是存放在一个文件夹内，这个文件夹内有好几个文件夹，怎么样才能实现调图片这个功能，比如照片是存放在z:\photo\content1\  z:\photo\content2\ 这些子目录下的，那我应该怎么改这些代码，谢谢

Answer 1

因为图片库非常大，现在已经有6W张了，估计不用多久会涨到10W张，一个文件夹内最多只能存放65536张图片，现在必须把这些图片分开放，而我们现在经常要批量地调图片，根据相应的DBF，所以不知道该怎么做

Answer 2

要么直接在rs(6)对应的字段中包含子目录名，例：
　　"content1\hello.jpg"
要么根据其他字段可以确定子目录名，比如：
　　ID 1～50000 的必定存放在 content1 下
　　ID 50001～100000 的必定存放在 content2 下
　　……
　　反正自己管理的文件，定好规则就可以，总比每个子目录下去查找要快很多。

Answer 3

如果照片肯定是存放在特定的三个文件夹内，那我要怎么写呢，如z:\photo\content1\  z:\photo\content2\ z:\photo\content3\ 怎么对这三个文件夹的图片进行遍历呢，我VB语法不太熟悉，望大虾们帮我一把，谢谢了

Answer 4

以下是我做的一个根据文件的创建时间来批量更改文件名的小程序，里面就包含遍历文件夹及子文件夹的功能
但愿对你有所帮助Option Explicit
'獲取某目錄下的所有子目錄路徑及名稱和檔的路徑及名稱
Public Sub SeachFile(ByVal strPath As String, strSourceEx As String, strObjectEx As String)
   On Error Resume Next
   Dim Fso As Object
   Dim Fol As Object
   Dim Fil As Object
   Dim DisFileName As String
   Dim OldName As String '更新前的名称
   
   Set Fso = CreateObject("Scripting.FileSystemObject")
   Set Fol = Fso.GetFolder(strPath)
   
   strSourceEx = UCase(strSourceEx)
   strObjectEx = UCase(strObjectEx)
   
   Dim sFileName As String '檔案名(不含副檔名)
   Dim sFileNameEx As String '副檔名
   Dim sFilePath As String '檔路徑
          
   For Each Fil In Fol.Files
       sFileNameEx = UCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(Fil.Name)) '副檔名
       If Trim(sFileNameEx) = "" Then '如果副檔名為空，則跳出本次迴圈
          GoTo NoEx
       End If
       sFileName = Left(Fil.Name, Len(Fil.Name) - Len(sFileNameEx) - IIf(Len(sFileNameEx) = 0, 0, 1))
       OldName = sFileName
       sFilePath = Fil.ParentFolder '取得父階文件夾路徑
       sFilePath = sFilePath & "\"
       labMsg.Caption = sFilePath & Chr(13) & Fil.Name
       DoEvents
       DisFileName = GetFileCreatedTime(CStr(Fil))
       If DisFileName = OldName Then '如果更新前后名称一样，则不做修改
          GoTo NoEx
       End If
       
CheckFileName:
       If Dir(sFilePath & DisFileName & "." & sFileNameEx, vbDirectory) <> "" Then '存在同名文件
          DisFileName = DisFileName & "A"
          GoTo CheckFileName
       End If
       
       Fso.MoveFile Fil, sFilePath & DisFileName & "." & sFileNameExNoEx:
   Next
   
   '掃描子目錄
   If SubCheck.Value = 1 Then
      For Each Fol In Fol.subfolders
           SeachFile Fol, strSourceEx, strObjectEx
      Next
   End If
End SubPrivate Sub btnStart_Click()
   Call SeachFile(txtPath.Text, "FDD", "FD")
   MsgBox "OK"
End SubPrivate Sub DriveList_Change()
   'On Error Resume Next
   DirList.Path = DriveList.Drive
End SubPrivate Sub DirList_Change()
   txtPath.Text = DirList.Path
End SubPrivate Function GetFileCreatedTime(lpFileNmae As String) As String
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(lpFileNmae)
    Dim GetTime As String
    GetFileCreatedTime = Format(f.DateLastModified, "YYYYMMDDHHMMSS")
End Function