10、生成文件夹下所有文件的目录

年景@

于 2024-06-12 08:23:12 发布

阅读量241

点赞数 3

文章标签： excel

本文链接：https://blog.csdn.net/weixin_73737526/article/details/139613141

版权

Sub search1()'定目录，返回文件目录树
    On Error GoTo 100
    Dim wsh As Object, mypath As String, ar, i&, br
    mypath = CreateObject("shell.application").BrowseForFolder(0, "请选择要搜索的文件夹", 0).Items.Item.Path    '在此指定目录
    Set wsh = CreateObject("wscript.shell")
    mypath = wsh.exec("cmd /c tree /f " & Chr(34) & mypath & Chr(34)).StdOut.ReadAll
    mypath = Left(mypath, Len(mypath) - 1)
    ar = Split(mypath, vbCrLf)
    ReDim br(1 To UBound(ar) + 1, 1 To 1)
    For i = 0 To UBound(ar)
        br(i + 1, 1) = ar(i)
    Next
    
    Range("a1").Resize(UBound(br)) = br
    Set wsh = Nothing
100:
End Sub

Sub search2()  '查找文件、文件夹，结果返回完整路径
    On Error GoTo 100
    Dim wsh As Object, mypath As String, ar, st$
    mypath = CreateObject("shell.application").BrowseForFolder(0, "请选择要搜索的文件夹", 0).Items.Item.Path    '在此指定目录
    st = InputBox("请输入要搜索的目标文件部分或全部名字。 比如：xls      如果“取消”就默认为全部文件。", _
         "文件名关键字", "xls")
    Set wsh = CreateObject("wscript.shell")
    mypath = wsh.exec("cmd /c dir /a /s /b /a-d " & Chr(34) & mypath & Chr(34)).StdOut.ReadAll
    mypath = Left(mypath, Len(mypath) - 1)
    ar = Split(mypath, vbCrLf)
    ar = Filter(ar, st)
    Set wsh = Nothing
    Cells.ClearContents
    Range("a1").Resize(UBound(ar) + 1) = Application.Transpose(ar)
    Hyperlinks.Add Anchor:=Application.Transpose(ar), Address:=Application.Transpose(ar)
100:
End Sub

'全盘查找指定文件
'以下代码单独放一个模块吧
 '原代码只适用VB7以前版本和Win32，加入PtrSafe后可适用VB7和Win64
Private Declare PtrSafe Function SearchTreeForFile Lib "ImageHlp.dll" (ByVal lpRoot As String, ByVal lpInPath As String, ByVal lpOutPath As String) As Long
Private Declare PtrSafe Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Function SearchFile(ByVal Filename As String) As String
    Dim R As Long, i As Long, SearchPath As String
    For i = 0 To 10
    SearchPath = Chr$(i + 65) & ":\"
    If GetDriveType(SearchPath) = 3 Then
        SearchFile = String$(1024, 0)
        R = SearchTreeForFile(SearchPath, Filename, SearchFile)
        If R <> 0 Then SearchFile = Split(SearchFile, Chr(0))(0): Exit Function
        End If
    Next
    SearchFile = "未能找到文件！"
End Function

Sub FindFile()
    Dim F As String
    F = InputBox("请输入要查找的文件名称！", "提示", "示例：excel.exe")
    [a1] = SearchFile(F)
End Sub