VBA7种遍历方法

朴灿烈づ我的快乐病毒、 2022-06-08 10:49 261阅读 0赞

Sub 简单遍历测试()
        For Each F In Dir遍历 'Office2003遍历,FSO遍历,双字典遍历,CMD遍历,栈遍历,管道遍历,Dir遍历
        '此处加入文件处理代码即可。
            Selection.InsertAfter F & Chr(13)
            i = i + 1
        Next
        Selection.InsertAfter i
    MsgBox "OKOK!!!", vbOKOnly, "OKKO"
    End Sub
     
    Sub 单个文档处理(F)
        Dim pa As Paragraph, c As Range
        With Documents.Open(F, Visible:=False)
            For Each pa In .Paragraphs
                For Each c In pa.Range.Characters
                    If c.Font.Name = "仿宋" And Abs(Asc(c)) > 128 Then
                        c.Font.Name = "仿宋_GB2312"
                    ElseIf c.Font.Name = "仿宋" And Abs(Asc(c)) < 128 Then
                        c.Font.Name = "Times New Roman"
                    End If
                Next
            Next
            .Close True
        End With
    End Sub
     
    ' 遍历文件夹
    Function CMD遍历()
        Dim arr
        Dim t: t = Timer
        With Application.FileDialog(msoFileDialogFolderPicker)
    '        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
            If .Show <> -1 Then Exit Function
            fod = .InitialFileName
        End With
        CMD遍历文件 arr, fod, "*.doc*"
        arr = Filter(arr, "*", False, vbTextCompare)
        CMD遍历 = arr
    End Function
     
    Function 栈遍历()
        Dim arr() As String
        Dim t: t = Timer
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show <> -1 Then Exit Function
            fod = .InitialFileName
        End With
        遍历栈 arr, CStr(fod), "doc*", True '这种方式就不用使用Function在函数中返回了
        栈遍历 = arr
    End Function
     
    Function 管道遍历()
        Dim t: t = Timer
        Dim a As New DosCMD
        Dim arr
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show <> -1 Then Exit Function
            fod = .InitialFileName
        End With
        a.DosInput Environ$("comspec") & " /c dir " & Chr(34) & fod & "\*.doc*" & Chr(34) & " /s /b /a:-d"
        arr = a.DosOutPutEx        '默认等待时间120s
        arr = Split(arr, vbCrLf)   '分割成数组
        arr = Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件
        arr = Filter(arr, "*", False, vbTextCompare)
        arr = Filter(arr, "$", False, vbTextCompare)
        管道遍历 = arr
        'For Each F In arr
        '   If InStr(F, "$") = 0 And F <> "" Then
        '   Debug.Print F
        '     '单个文档处理代码 (F)'------------------------------------------------------------------------------★★★★★★★★★★★★★★★
        '   End If
        'Next
        'MsgBox "已完成！!!", vbOKCancel, "代码处理"
    End Function
     
    Function AllName()    '遍历获得文件名，交给数组，不变的部分；'选定的所有word文档
        With Application.FileDialog(msoFileDialogFilePicker)
            .Filters.Add "选择03版word文档", "*.doc", 1
            .Filters.Add "所有文件", "*.*", 2
            If .Show <> -1 Then Exit Function
            For Each F In .SelectedItems
                If InStr(F, "$") = 0 Then
                    str0 = str0 & F & Chr(13)
                End If
            Next
        End With
        AllName = Left(str0, Len(str0) - 1)
    End Function
     
    Function AllFodName()    '用dos命令遍历选定文件夹下的所有word文档
        Dim fso As Object
        Dim aCollection As New Collection
        Set fso = CreateObject("scripting.filesystemobject")
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "选择文档所在文件夹"
            If .Show <> -1 Then Exit Function
            folder = .SelectedItems(1)
        End With
        Set ws = CreateObject("WScript.Shell")
        '    ws.Run Environ$("comspec") & " /c dir " & folder & "\*.ppt /s /a:-d /b/on|find /v" & Chr(34) & ".pptx" & Chr(34) & "> C:\temp.txt", 0, True
        ws.Run Environ$("comspec") & " /c dir " & Chr(34) & folder & Chr(34) & "\*.doc* /s /a:-d /b/on" & "> C:\temp.txt", 0, True
     
        Open "C:\temp.txt" For Input As #1
        arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
        Close #1
        ws.Run Environ$("comspec") & " /c del /q /s " & Chr(34) & "C:\temp.txt" & Chr(34), 0, False    '删除临时文件
        Set ws = Nothing
        '    '--------------------------此处是否多此一举？-----------------------
        '    For i = LBound(arr) To UBound(arr) - 1  '使用集合提高效率
        '        aCollection.Add arr(i)
        '    Next
        '    '--------------------------------------------------------------------
        '    For i = 0 To UBound(arr)
        ''        aname = CreateObject("Scripting.FileSystemObject").GetBaseName(arr(i))
        ''        If InStr(1, aname, "$") = 0 Then
        '         If InStr(1, arr(i), "$") = 0 Then Debug.Print arr(i)
        '         Selection.InsertAfter arr(i)
        ''        End If
        '    Next
        AllFodName = arr
    End Function
     
    Function FSO遍历()    '我的得意代码之十五！！！文档不引用
    '*------------------------------------------------------------------------------*
        Dim fso As Object, b As Object, arr() As String, F '注意,这里的as string是必须,否则,filter函数无法使用。因为收集的不是字符串形式的地址
        Set fso = CreateObject("scripting.filesystemobject")
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show <> -1 Then Exit Function
            fod = .InitialFileName
        End With
        For Each F In fso.GetFolder(fod).Files  '目录本身的
            ReDim Preserve arr(i)
            arr(i) = F
            i = UBound(arr) + 1
        Next
        查找子目录 fod, arr, fso
        arr = Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件
        arr = Filter(arr, "*", False, vbTextCompare)
        arr = Filter(arr, "$", False, vbTextCompare) '过滤掉带有$符号的文件
        FSO遍历 = arr
        Set fso = Nothing
    End Function
    Function 查找子目录(ByVal fod As String, arr, fso)
        If fso.FolderExists(fod) Then
            If Len(fso.GetFolder(fod)) = 0 Then
                Debug.Print "文件夹" & fod & " 是空的！" '这里似乎用不上
            Else
                For Each zi In fso.GetFolder(fod).SubFolders
                    For Each F In zi.Files '子目录中的
                        i = UBound(arr) + 1
                        ReDim Preserve arr(i)
                        arr(i) = F
                    Next
                    查找子目录 zi, arr, fso
                Next
            End If
        End If
    End Function
     
    Function Dir遍历()
    Dim arr() As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show <> -1 Then Exit Function
            fod = .InitialFileName
        End With
    处理子目录 fod, arr
        arr = Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件
        arr = Filter(arr, "$", False, vbTextCompare) '过滤掉带有$符号的文件
    Dir遍历 = arr
    End Function
    Sub 处理子目录(p, arr)
    On Error Resume Next
        Dim a As String, b() As String, c() As String
        If Right(p, 1) <> "\" Then p = p + "\"
        MY = Dir(p, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
        Do While MY <> ""
            If MY <> ".." And MY <> "." Then
                If (GetAttr(p + MY) And vbDirectory) = vbDirectory Then
                    n = n + 1
                    ReDim Preserve b(n)
                    b(n - 1) = MY
                Else
                On Error Resume Next
                    i = UBound(arr) + 1
                On Error GoTo 0
                    ReDim Preserve arr(i)
                    arr(i) = p + MY
                End If
            End If
            MY = Dir
        Loop
        For j = 0 To n - 1
            处理子目录 (p + b(j)), arr
        Next
        ReDim b(0)
    End Sub
     
    Function Office2003遍历()    '-------------参考
        Dim sFile As String, arr() As String
        With Application.FileDialog(msoFileDialogFolderPicker)
    '        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
            If .Show <> -1 Then Exit Function
            bc = .InitialFileName
        End With
        Set mySearch = Application.FileSearch    '定义一个Application.FileSearch
            With mySearch
                .NewSearch    '设置一个新搜索
                .LookIn = bc    '在该驱动器盘符下
                .SearchSubFolders = True    '搜索子文件夹
                '    .FileType = msoFileTypeWordDocuments           '以此可以定义文件类型
                .FileName = "*.DOc*"    '搜索一个指定文件，此处为任意WORD模板文件
                If .Execute() > 0 Then    '开始并搜索成功
                    For i = 1 To .FoundFiles.Count
                        ReDim Preserve arr(i - 1)
                        arr(i - 1) = .FoundFiles(i)
                    Next i
                End If
            End With
    Office2003遍历 = arr
    End Function
     
     
    Function 双字典遍历()    ' 字典分为word的dictionary和scripting的dictionary，这里的是后者。
        Dim d1, d2    'as Dictionary
        Set d1 = CreateObject("scripting.dictionary")
        Set d2 = CreateObject("scripting.dictionary")
        With Application.FileDialog(msoFileDialogFolderPicker)
            '.InitialFileName = "D:\"   '若不加这句则打开上次的位置
            If .Show <> -1 Then Exit Function
            path1 = .InitialFileName
        End With
        d1.Add path1, ""  '目录最后一个字符必须为"\"
        '*---------------------------第一个字典获取目录总数和名称----------------------------*
        i = 0    '
        Do While i < d1.Count    '第几个i就是进入第几个文件夹！i从0开始。d1.count为找到的文件夹总数。
            ke = d1.keys
            ML = Dir(ke(i), vbDirectory)
            Do While ML <> ""
                'Debug.Print d1.Count
                If ML <> "." And ML <> ".." Then
                    If (GetAttr(ke(i) & ML) And vbDirectory) = vbDirectory Then    '第一个括号必须有
                        d1.Add ke(i) & ML & "\", ""
                    End If
                End If
                ML = Dir()
            Loop
            i = i + 1
        Loop
        '*---------------------------第二个字典获取各个目录的文件名----------------------------*
        For Each ke In d1.keys
            fa = Dir(ke & "*.doc*")    '也可以是“*.*”，也可以用fso操作这里
            Do While fa <> ""
                '            d2.Add fa, "ite"    'dictionary的item可以相同，可以为空，而key决不可相同，是唯一的！
                d2.Add ke & fa, "ite"    'dictionary的item可以相同，可以为空，而key决不可相同，是唯一的！【加了ke & ，完整路径；】
                fa = Dir  '上面的"ite"可以改成"",或任意其他值。
            Loop
        Next
        '*--------------------------ke在这里可循环利用，打印看看key和item都是什么----------------------------*
        '    For Each ke In d2.keys
        '        Debug.Print ke
        '    Next
        '    For Each ke In d2.Items
        '        Debug.Print ke
        '    Next
        '*---------------------------最后释放字典对象----------------------------*
        双字典遍历 = d2.keys
        Set d1 = Nothing
        Set d2 = Nothing
    End Function
     
     
    Function CMD遍历文件(ByRef arr, ByVal aPath$, ByVal aExtensionName$)
        Dim aNum%
        Dim t: t = Timer
        With CreateObject("WScript.Shell")
            If Right(aPath, 1) <> "\" Then aPath = aPath & "\"
            .Run Environ$("comspec") & " /c dir " & Chr(34) & aPath & aExtensionName & Chr(34) & " /s /b /a:-d > C:\tmpDoc.txt", 0, True    '遍历获取Word文件，并列表到临时文件，同步方式
            aNum = FreeFile()                                     '空闲文件号[上面最后一个参数true的作用是等待cmd语句执行完毕后再执行下面的语句]
            Open "C:\tmpDoc.txt" For Input As #aNum
            arr = Split(StrConv(InputB(LOF(aNum), aNum), vbUnicode), vbCrLf)    '将遍历结果从文件读取到数组中
            Close #aNum
            '.Run Environ$("comspec") & " /c del /q /s " & Chr(34) & "C:\tmpDoc.txt" & Chr(34), 0, False    '删除临时文件，异步方式
        End With
        arr = Filter(arr, "$", False, vbTextCompare)                        '不包含$，即非word临时文件
    End Function
     
    'http://club.excelhome.net/thread-1319867-4-1.html
    '原创：wzsy2_mrf
     
    Function FolderSearch(ByRef mlNameArr() As String, pPath As String, pSub As Boolean)  '搜索子目录
    'mlNameArr装文件名动态数组，pSub子目录开关，pPath搜索起始路径
        On Error Resume Next
        Dim DirFile, mf&, pPath1$
        Dim workStack$(), top&    'workstack工作栈,top栈顶变量
        pPath = Trim(pPath)
        If Right(pPath, 1) <> "\" Then pPath = pPath & "\"    ' 对搜索路径加 backslash（反斜线）
        pPath1 = pPath
        top = 1
        ReDim Preserve workStack(0 To top)
        Do While top >= 1
            DirFile = Dir(pPath1, vbDirectory)
            Do While DirFile <> ""
                If DirFile <> "." And DirFile <> ".." Then
                    If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                        mf = mf + 1
                        ReDim Preserve mlNameArr(1 To mf)
                        mlNameArr(mf) = pPath1 & DirFile
                    End If
                End If
                DirFile = Dir
            Loop
            If pSub = False Then Exit Function
            DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
            Do While DirFile <> ""
                If DirFile <> "." And DirFile <> ".." Then
                    If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                        workStack(top) = pPath1 & DirFile & "\"    '压栈
                        top = top + 1
                        If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
                    End If
                End If
                DirFile = Dir
            Loop
            If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
        Loop
    End Function
     
    Function 遍历栈(ByRef fileNameArr() As String, pPath As String, pMask As String, pSub As Boolean)
    'fileNameArr装文件名动态数组，psb子目录开关,pPath搜索起始路径，pMask扩展名(如doc)
        On Error Resume Next
        Dim DirFile, mf&, pPath1$
        Dim workStack$(), top&    'workstack工作栈,top栈顶变量
        pPath = Trim(pPath)
        If Right(pPath, 1) <> "\" Then pPath = pPath & "\"    ' 对搜索路径加 backslash（反斜线）
        pPath1 = pPath
        top = 1
        ReDim Preserve workStack(0 To top)
        Do While top >= 1
            DirFile = Dir(pPath1 & "*." & pMask)
            Do While DirFile <> ""
                mf = mf + 1
                ReDim Preserve fileNameArr(1 To mf)
                fileNameArr(mf) = pPath1 & DirFile
                DirFile = Dir
            Loop
            If pSub = False Then Exit Function
            DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
            Do While DirFile <> ""
                If DirFile <> "." And DirFile <> ".." Then
                    If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                        workStack(top) = pPath1 & DirFile & "\"    '压栈
                        top = top + 1
                        If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
                    End If
                End If
                DirFile = Dir    'next file
            Loop
            If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
        Loop
    End Function