不能遍历文件夹只能在第一层路径查询

带翅膀老虎

'API声明
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
'最大路径长度和文件属性常量的定义
Public Const MAX_PATH = 260
'这里有文件属性，包括文件夹、隐藏等
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
'文件结构
Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Sub Main()
    Dim FindData As WIN32_FIND_DATA
    Dim FindHandle As Long
    Dim FindNextHandle As Long
    Dim FPath As String
    Dim FName As String
    Dim FileName1

    Set Dic = CreateObject("Scripting.Dictionary")    '创建本地数组字典对象
    Set Did = CreateObject("Scripting.Dictionary")    '创建本地数组字典对象
    Set objShell = CreateObject("Shell.Application") '创建网络路径对象
    Set objFolder = objShell.BrowseForFolder(0, "选择网络表文根目录", 0, 0) '网络文件夹赋值

      If Not objFolder Is Nothing Then
              lj = objFolder.self.path & "\"     '路径变量赋值
         Else: Exit Sub  '路径变量赋值为空直接退出
      End If

    tms = Timer
    'FPath = ThisWorkbook.Path '本文件所在路径
    FPath = lj
    FName = "*"
     Did.Add (lj), "" '数组路径变量赋值
    i = 0
    Do While i < Did.Count '集合中的数目条目数
        Ke = Did.keys   '开始遍历文件夹字典
    tms = Timer
    ' FPath = ThisWorkbook.path '本文件所在路径

    '开始API查找，找到的文件属性在FindData里
    FindHandle = FindFirstFile(Ke(i) & FName, FindData)
    FileName1 = FindData.cFileName '本文件所在路径
    ' MsgBox FPath & FileName1

    '如果找到，则返回不为0。发生错误返回-1
    If FindHandle <> 0 And FindHandle <> -1 Then
        Do
            FindNextHandle = FindNextFile(FindHandle, FindData)
            FileName1 = FindData.cFileName
            ' MsgBox FPath & FileName1
            If FindNextHandle <> 0 And FindNextHandle <> -1 Then
                If FindData.dwFileAttributes <> FILE_ATTRIBUTE_DIRECTORY Then
                  FileName1 = FindData.cFileName
                  Dic.Add (Ke(i) & FileName1), FileName1    '就往字典中添加这个文件名作为一个条目
                 ' MsgBox FPath & FileName
               FindData.cFileName = ""
                Else:


                Did.Add (Ke(i) & FileName1 & "\"), FileName1     '就往字典中添加这个文件夹作为一个条目

                End If
            Else
                Exit Do
            End If
        Loop
    End If
     i = i + 1
        Loop
       FindClose FindHandle  '关闭文件搜索
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.ClearContents
            f = True
            Exit For
        Else
            f = False
        End If
    Next
    If Not f Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "XLS文件清单"    '当前工作簿最后创建新工作表
    End If
       aa = UBound(Dic.keys) '查找结果文件名数组界
Sheets("XLS文件清单").[A1].Resize(Dic.Count, 1) = WorksheetFunction.Transpose(Dic.keys) '写入查找含路径结果
Sheets("XLS文件清单").[j1].Resize(Dic.Count, 1) = WorksheetFunction.Transpose(Dic.items()) '文件名已经存在输出
  Sheets("XLS文件清单").[d1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys) '写入查找含路径结果
MsgBox Format(Timer - tms, "0.000s ")
MsgBox i



End Sub
'去除非法字符
Public Function fDelInvaildChr(str As String) As String
    On Error Resume Next
    Dim i As Long
    For i = Len(str) To 1 Step -1
        If Asc(Mid(str, i, 1)) <> 0 And Asc(Mid(str, i, 1)) <> 32 Then
            fDelInvaildChr = Left(str, i)
            Exit For
        End If
    Next
End Function

带翅膀老虎

求助各位大神我猜想是文件夹路径数据处理出错了，只是不知道怎么修改

带翅膀老虎

Did.Add (Ke(i) & FileName1 & "\"), FileName1     '就往字典中添加这个文件夹作为一个条目应该是这句出错就是不知道怎么修改

带翅膀老虎

有人看到吗
如何把api的数据格式弄正确

带翅膀老虎

求助大神帮忙解决数据的问题