VBA7种文档遍历法

Sub 在选定文档最后加入一句话() '遍历文件  
    Dim MyDialog As FileDialog  
    On Error Resume Next  
Application.ScreenUpdating = False  
    Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)  
    With MyDialog  
'        .InitialFileName = "C:\"  
        .Filters.Clear    '清除所有文件筛选器中的项目  
        .Filters.Add "所有 WORD 文件", "*.doc", 1  '增加筛选器的项目为所有WORD文件  
        .AllowMultiSelect = True    '允许多项选择  
        If .Show = -1 Then    '确定  
            For Each i In .SelectedItems    '在所有选取项目中循环  
                With Documents.Open(i, , , , , , , , , , , False)  
                    .Range.InsertAfter Chr$(13) & "改成你想加入的话................"  
                    .Close True  
                    End With  
            Next  
        End If  
    End With  
Application.ScreenUpdating = True  
End Sub  

　　

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  
</pre>  
Function fso遍历2()  
Dim fso As Object, fod As Object, arr()  
Set fso = CreateObject("Scripting.FileSystemObject")  
    With Application.FileDialog(msoFileDialogFolderPicker)  
        If .Show <> -1 Then Exit Function  
        Set fod = fso.GetFolder(.SelectedItems(1))  
    End With  
Call 递归(fod, arr, i)  
ReDim Preserve arr(i - 1)  
fso遍历2 = arr  
Set fso = Nothing  
Set fod = Nothing  
End Function  
Function 递归(fod, arr, i)  
    Dim SubFolder As Object  
    Dim File As Object  
    For Each File In fod.Files  
        ReDim Preserve arr(i)  
        arr(i) = File.Path  
        i = i + 1  
    Next  
    ReDim Preserve arr(i)  
    For Each SubFolder In fod.SubFolders  
        递归 SubFolder, arr, i  
    Next  
End Function  
Function DIR词典遍历()  
Dim d1 As Object, arr()  
Set d1 = CreateObject("scripting.dictionary")  
With Application.FileDialog(msoFileDialogFolderPicker)  
    If .Show = -1 Then fod = .InitialFileName Else Exit Function  
End With  
 d1.Add fod, ""  
        js = 0   '词典计数器，起到类似递归的作用，随着不断的增加，逐渐深入到新加入的目录中；  
    Do While js < d1.Count    '第几个i就是进入第几个文件夹！i从0开始。d1.count为找到的文件夹总数。  
        ke = d1.keys  
        ML = Dir(ke(js), vbDirectory) 
        Do While ML <> "" 
            If ML <> "." And ML <> ".." Then '这两个点，一个代表本目录，另一个代表上级目录parent，dir方式总会有  
                If (GetAttr(ke(js) & ML) And vbDirectory) = vbDirectory Then    '第一个括号必须有  
                    d1.Add ke(js) & ML & "\", ""  
                Else  
                    If InStr(ML, "doc") > 0 And InStr(ML, "$") = 0 Then  
                         ReDim Preserve arr(i)  
                         arr(i) = ke(js) & ML
                         i = i + 1 
                    End If  
                End If 
            End If
            ML = Dir()
        Loop
        js = js + 1
    Loop
End Function