[问题求助] vbs如何实现输出指定路径/目录/文件夹下所有子文件夹及文件的路径

Dim objShell
Set objShell = CreateObject("WSCript.Shell")
objShell.Run "cmd /k dir D:\"
Set objShell = NothingCOPY

' +----------------------------------------------------------------------------+
' | 递归查找文件类：可自定义扫描目录层数、文件类型 |
' +----------------------------------------------------------------------------+
Class Scan_Folder
    ' ==============================================================================================================
    ' 类初始化
    ' ==============================================================================================================
    ' 公共变量
    Private fso, regEx, sFolderSpec, sParentFolderLayer, sMaxLayer, sFileType_RegExPatternt, sFileType, sFileList, sFolderList, sEmptyFolderList
    Private Scan_Folder_Only, Scan_Folder_Sub
    '类初始化事件
    Private Sub Class_Initialize
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set regEx = CreateObject("VBScript.RegExp")     ' 建立正则表达式。
            regEx.IgnoreCase = True     ' 设置是否区分大小写。
            regEx.Global = True         ' 设置全局替换。
            regEx.MultiLine = True      ' 设置多行匹配模式
        Scan_Folder_Only = True           ' 仅扫描文件夹(提高效率)
        Scan_Folder_Sub = True            ' 扫描子文件夹
    End Sub
    ' ==============================================================================================================
    ' 获取设定
    ' ==============================================================================================================
    ' 设置扫描目录
    Public Function FolderSpec(ByVal strFolderSpec)
        sFolderSpec = strFolderSpec
    End Function
    ' 设置最大扫描目录层数
    Public Function MaxLayer(ByVal strMaxLayer)
        sMaxLayer = strMaxLayer
    End Function
    ' 设置扫描的文件类型
    Public Function FileType_RegExPatternt(ByVal strFileType_RegExPatternt)
        sFileType_RegExPatternt = strFileType_RegExPatternt
    End Function
    ' 获取文件夹列表(包括空文件夹)
    Public Function GetFolderList()
        Scan_Folder_Only = True
        Scan_Layer sFolderSpec
        GetFolderList = sFolderList
    End Function
    ' 获取空文件夹列表
    Public Function GetEmptyFolderList()
        Scan_Folder_Only = False
        Scan_Layer sFolderSpec
        GetEmptyFolderList = sEmptyFolderList
    End Function
    ' 获取文件列表
    Public Function GetFileList()
        Scan_Folder_Only = False
        Scan_Layer sFolderSpec
        GetFileList = sFileList
    End Function
    ' 关闭控件
    Public Sub Close()
        Set fso = Nothing
        Set regEx = Nothing
    End Sub
    ' ==============================================================================================================
    ' 私有函数
    ' ==============================================================================================================
    ' 递归扫描
    Private Function Scan_Layer(strFolderspec)
        On Error Resume Next
        If Not Right(strFolderspec,1) = "\" Then strFolderspec = strFolderspec & "\"
        If Not IsEmpty(sFolderList) Then sFolderList = sFolderList & vbCrLf
        sFolderList = sFolderList & strFolderspec
        ' 文件夹对象
        Dim oFolder, oSubFolderItems, oSubFileItems, oSubFolder, oSubFile
        Set oFolder = fso.GetFolder(strFolderspec)
        ' 是否扫描 当前文件夹 的 子文件
        If Scan_Folder_Only = False Then
            ' 子文件对象集合
            Set oSubFileItems = oFolder.Files
            ' 查找当前文件夹 的 文件
            If oSubFileItems.Count <> 0 Then
                For Each oSubFile In oSubFileItems
                    If IsEmpty(sFileType_RegExPatternt) Or (sFileType_RegExPatternt = "") Then
                        If Not IsEmpty(sFileList) Then sFileList = sFileList & vbCrLf
                        sFileList = sFileList & oSubFile.Path
                    Else
                        ' 过滤文件类型(适用正则表达式)
                        regEx.Pattern = sFileType_RegExPatternt
                        If regEx.Execute( fso.GetExtensionName(oSubFile) ).Count > 0 Then
                            If Not IsEmpty(sFileList) Then sFileList = sFileList & vbCrLf
                            sFileList = sFileList & oSubFile.Path
                        End If
                    End If
                Next
            End If
        End If
        ' 查找当前文件夹 的 子文件夹
        Set oSubFolderItems = oFolder.SubFolders        ' 子文件夹对象集合
        ' --------没有子文件夹时
        If oSubFolderItems.Count = 0 Then
            ' --------也没有子文件时(此文件夹为空)
            If Scan_Folder_Only = False Then
                If oSubFileItems.Count = 0 Then
                    If Not IsEmpty(sEmptyFolderList) Then sEmptyFolderList = sEmptyFolderList & vbCrLf
                    sEmptyFolderList = sEmptyFolderList & strFolderspec
                End If
            End If
        Else
            ' 限制递归的最大层数
            If Not (IsEmpty(sMaxLayer) Or (sMaxLayer = "")) Then
                Dim s, f, n
                s = Replace(strFolderspec, sFolderSpec, "", vbTextCompare, -1, 1)
                f = "\"
                n = (Len(s)-Len(Replace(s,f,"",vbTextCompare,-1,1)))/Len(f)    ' 统计字符串中某一单词出现次数
                If sMaxLayer < n Then Scan_Folder_Sub = False
            Else
                Scan_Folder_Sub = True
            End If
            If Scan_Folder_Sub = True Then
                ' ----有子文件夹时，递归查找
                For Each oSubFolder In oSubFolderItems
                    'sFolderList = sFolderList & oSubFolder.Path & vbCrLf
                    Scan_Layer oSubFolder.Path
                Next
            End If
        End If
    End Function
End Class
' 实例
Sub Demo(ByVal strFolderPath)
    Dim oScanDir, sFileList, sFolderList
    ' 创建对象
    Set oScanDir = New Scan_Folder
    ' 指定文件夹
    oScanDir.FolderSpec strFolderPath
    ' 设定扫描最大层数(可为空。默认扫描所有子文件夹)
    'oScanDir.MaxLayer 2
    ' 指定文件类型(可为空。正则表达式规则，默认则返回所有文件)
    oScanDir.FileType_RegExPatternt "(jpg|mp4)"
    ' 获取结果(必填。GetFileList返回文件列表，GetFolderList返回目录列表，GetEmptyFolderList返回空目录列表)
    sFileList = oScanDir.GetFileList
    sFolderList = oScanDir.GetFolderList
    ' 结束对象
    oScanDir.Close
 
    ' 对返回的结果进行操作(这里是获取属性)
    Set fso = CreateObject("Scripting.FileSystemObject")
    arrFilePath = Split(sFileList, vbCrLf, -1, vbTextCompare)
    For i = 0 To UBound(arrFilePath)
        strFilePath = arrFilePath(i)
        WScript.Echo "所在目录: " & fso.GetFile(strFilePath).ParentFolder
        WScript.Echo "名称: " & fso.GetFile(strFilePath).Name
        WScript.Echo "大小: " & fso.GetFile(strFilePath).Size
        WScript.Echo "最后修改时间: " & fso.GetFile(strFilePath).DateLastModified
    Next
End SubCOPY

Function GetCurrentFolderFullPath  
Set fso = CreateObject("Scripting.FileSystemObject")  
GetCurrentFolderFullPath = fso.GetParentFolderName(WScript.ScriptFullName)  
 End Function
 '以上代码得到该脚本所在的路径
 
Function GetSubFolders(currentFolderFullPath)  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set currentFolder = fso.GetFolder(currentFolderFullPath)  
    Set subFolderSet = currentFolder.SubFolders  
    For Each subFolder in subFolderSet  
        'MsgBox "subFolder.Path=" & subFolder.Path   
        GetSubFolders =subFolder.Path  & vbcrlf  & GetSubFolders &  
 
GetSubFolders(subFolder.Path)   
         Next  
End Function  
MsgBox GetSubFolders(GetCurrentFolderFullPath)COPY

Call Demo("D:\")COPY

Dim strPath
strPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%")
WScript.Echo ScanFolder(strPath)
 
Function ScanFolder(ByVal strPath)
    Dim arr()
    ReDim Preserve arr(0)
    Call SCAN_FOLDER(arr, strPath)
    ReDim Preserve arr(UBound(arr) - 1)
    ScanFolder = Join(arr, vbCrLf)
End Function
Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
    On Error Resume Next
    Dim fso, objItems, objFile, objFolder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objItems = fso.GetFolder(folderSpec)
    If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
    If (Not fso.FolderExists(folderSpec)) Then Exit Function
    For Each objFile In objItems.Files
        arr(UBound(arr)) = objFile.Path
        ReDim Preserve arr(UBound(arr) + 1)
    Next
    For Each objFolder In objItems.subfolders
        Call SCAN_FOLDER(arr, objFolder.Path)
    Next
    arr(UBound(arr)) = folderSpec
    ReDim Preserve arr(UBound(arr) + 1)
End FunctionCOPY

VBS 文件操作对象FSO大全
http://blog.sina.com.cn/s/blog_611f50100100w7tv.htmlCOPY