word遍历方法大全

CMD，FSO+双字典，堆栈（最快），DIR

Sub 单个文档处理(F)
    Dim pa As Paragraph, c As Range
With Documents.Open(F)
For Each pa In ActiveDocument.Paragraphs
    For Each c In pa.Range.Characters
    
        If c.Font.Name = "仿宋" And Asc(c) > 128 Then
        c.Font.Name = "仿宋_GB2312"
        ElseIf c.Font.Name = "仿宋" And Asc(c) < 128 Then
        c.Font.Name = "Times New Roman"
        End If
    Next
Next
.Close True
End With
End Sub



Sub 简单遍历测试()
For Each F In AllFodName
If F <> "" And InStr(F, "$") = 0 Then
    Call 单个文档处理(F)
End If
Next
MsgBox "OKOK!!!", vbOKCancel, "OKKO"
End Sub





' 遍历文件夹
Sub 遍历_ShellCMD()
Dim arr
Dim t: t = Timer
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\"   '若不加这句则打开上次的位置
    If .Show <> -1 Then Exit Sub
    fod = .InitialFileName
End With
CMD遍历文件 arr, fod, "*.doc"
Debug.Print Timer - t
For Each F In arr
   If InStr(F, "$") = 0 And F <> "" Then
     '文档处理 (F)'------------------------------------------------------------------------------★★★★★★★★★★★★★★★
   End If
Next
MsgBox "已完成！!!" & UBound(arr) & vbTab & Timer - t & vbCrLf
End Sub

Sub 遍历_模拟栈()
Dim arr() As String
Dim t: t = Timer
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\"   '若不加这句则打开上次的位置
    If .Show <> -1 Then Exit Sub
    fod = .InitialFileName
End With

遍历栈 arr, CStr(fod), "doc", True

For Each F In arr
   If InStr(F, "$") = 0 And F <> "" Then
   Debug.Print F
     '文档处理 (F)'------------------------------------------------------------------------------★★★★★★★★★★★★★★★
   End If
Next

'strA = strA & UBound(arr) & vbTab & Timer - t & vbCrLf
'Debug.Print Timer - t
MsgBox "已完成！!!", vbOKCancel, "代码处理"
End Sub

Sub 遍历_管道()
Dim t: t = Timer
Dim a As New DosCMD
Dim arr
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\"   '若不加这句则打开上次的位置
    If .Show <> -1 Then Exit Sub
    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)
arr = Filter(arr, "*", False, vbTextCompare)
arr = Filter(arr, "$", False, vbTextCompare)
For Each F In arr
   If InStr(F, "$") = 0 And F <> "" Then
   Debug.Print F
     '单个文档处理代码 (F)'------------------------------------------------------------------------------★★★★★★★★★★★★★★★
   End If
Next
MsgBox "已完成！!!", vbOKCancel, "代码处理"
End Sub

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

Sub 文件系统对象遍历文档不引用()    '我的得意代码之十五！！！
'*------------------------------------------------------------------------------*
    Dim a As Object, b As Object, c As Object, D As Object, bc As String, bb
    '*------------------------------------------------------------------------------*
    '    Dim a As New FileSystemObject, b As File, bb As File, c As Folder, d As Folder, bc As String  ’等价代码
    '*------------------------------------------------------------------------------*
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
        If .Show <> -1 Then Exit Sub
        bc = .InitialFileName
    End With
    Set a = CreateObject("scripting.filesystemobject")   '若是使用引用则这句可不用
    Set c = a.GetFolder(bc)
    For Each b In c.Files
        Debug.Print b.Name, b, b.Path
        Debug.Print b.Type
        If b.Type = "Microsoft Word 文档" Then
            With Documents.Open(CStr(b), Visible:=True)    '若不用Cstr函数会出错！！！
处理单个文档 '------------------------------------------------------------------------------★★★★★★★★★★★★★★★
            End With
        End If
        For Each D In c.SubFolders
            For Each bb In D.Files
                If bb.Type = "Microsoft Word 文档" Then
                    With Documents.Open(CStr(bb), Visible:=True)
处理单个文档 '------------------------------------------------------------------------------★★★★★★★★★★★★★★★
                    End With
                End If
            Next
        Next
    Next
    Set a = Nothing
    Set b = Nothing
    Set c = Nothing
    Set D = Nothing
    MsgBox "已完成！!!"
End Sub
Function 处理单个文档()
With ActiveDocument
    .Range.InsertAfter 4.56545646482222E+22
    .Close True
    End With
End Function

Sub Office2003遍历() '-------------参考
Dim sFile As String
Dim fs As New FileSearch2
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
        If .Show <> -1 Then Exit Sub
        bc = .InitialFileName
    End With
    With fs
        .LookIn = bc
        .SearchSubFolders = True
        .SearchSubFolders = True
        .FileName = "*.doc"
        If .Execute > 0 Then
            Debug.Print "OK"
            For i = 1 To .FoundFiles.Count
                Debug.Print .FoundFiles.Count; "个！！！"
                sFile = .FoundFiles(i)
                文档处理 (sFile) '文档处理代码'------------------------------------------------------------------------------★★★★★★★★★★★★★★★
            Next
        End If
    End With
    MsgBox "已完成！!!", vbOKCancel, "程序处理"
End Sub

Sub 调用双字典()
    With Application.FileDialog(msoFileDialogFolderPicker)
        '.InitialFileName = "D:\"   '若不加这句则打开上次的位置
        If .Show <> -1 Then Exit Sub
        path1 = .InitialFileName
    End With
    mm = 双字典法学习(path1)
    For Each ke In mm
        Debug.Print ke '这里获取文件名,单个文档处理即可从此开始
        Selection.InsertAfter ke
        '文档处理 (ke) '------------------------------------------------------------------------------★★★★★★★★★★★★★★★
    Next
MsgBox "已完成！!!", vbOKCancel, "程序处理"
End Sub
Function 双字典法学习(path1)    ' 字典分为word的dictionary和scripting的dictionary，这里的是后者。
    Dim d1, d2    'as Dictionary
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    '    path1 = "C:\123\"
    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


Sub 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()                                     '空闲文件号
        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 Sub

'http://club.excelhome.net/thread-1319867-4-1.html
'原创：wzsy2_mrf

Sub 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 Sub
        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 Sub

Sub 遍历栈(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 Sub
        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 Sub

还有待完善的：

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 获得全部目录下文件名称() '实用价值不大。需要修改
Dim F
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show <> -1 Then Exit Sub
        path1 = .InitialFileName
    End With
    mulu = Left(path1, InStr(path1, "\"))
    ChDrive mulu
    ChDir (path1)
    F = Dir("*.*")
    Do While F <> ""
        Debug.Print F
        F = Dir
    Loop
    查找子目录 (path1)
End Sub
Function 查找子目录(ByVal TD As String)
    Dim fs As New FileSystemObject, F
    If fs.FolderExists(TD) Then
        If Len(fs.GetFolder(TD)) = 0 Then
            Debug.Print "文件夹" & TD & " 是空的！"
        Else
            Dim Zi
            For Each Zi In fs.GetFolder(TD).SubFolders
                For Each F In Zi.Files
                    Debug.Print F
                Next
                查找子目录 (Zi)
            Next
        End If
    End If
End Function




Sub 循环遍历所有文件2()  ’这个意义似乎也不大，需要全局遍历aa，容易出问题；
aa = ""
子文件 ("c:\y")
Debug.Print aa
aa = Left(aa, Len(aa) - 1)
For Each i In Split(aa, "*")
On Error Resume Next
Application.ScreenUpdating = False
'*------------单个文件处理代码-------------*
With Documents.Open(CStr(i), Visible = True)
    .Range.InsertBefore "hhhhhaaaa,OKOKOKO!!!!!!!!!" + vbNewLine
    .Close True
End With
'*---------------------------------------*
Application.ScreenUpdating = True
Next
aa = ""
End Sub
Sub 子文件(p As String)
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:
        aa = aa & p + MY & "*"
        End If
    End If
        MY = Dir
Loop
For j = 0 To n - 1
子文件 (p + b(j))
Next
ReDim b(0)
End Sub


Sub 文件系统对象遍历()    '我的得意代码之十五.2！！！【有问题】
'*------------------------------------------------------------------------------*
'*------------------------------------------------------------------------------*
    Dim a As New FileSystemObject, b As File, bb As File, c As folder, d As folder, bc As String  '等价代码
'*------------------------------------------------------------------------------*
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
        If .Show <> -1 Then Exit Sub
        bc = .InitialFileName
    End With
    Set a = CreateObject("scripting.filesystemobject")   '若是使用引用则这句可不用
    Set c = a.GetFolder(bc)
        Do While c.SubFolders.Count > 0
            For Each d In c.SubFolders
            m = m + 1
                For Each bb In d.Files
Debug.Print bb; d, c
                Next
            Next
            Debug.Print c,
'         cstr(c) = Split(st, ";")(1)
        Loop
        MsgBox "已完成！!!", vbOKCancel, "程序处理"
End Sub

Sub 文件系统对象遍历()    '我的得意代码之十五.2！！！
'*------------------------------------------------------------------------------*
'*------------------------------------------------------------------------------*
    Dim a As New FileSystemObject, b As File, bb As File, c As folder, D As folder, bc As String  '等价代码
    Dim co As New Collection
'*------------------------------------------------------------------------------*
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:\"   '若不加这句则打开上次的位置
        If .Show <> -1 Then Exit Sub
        bc = .InitialFileName
    End With
    Set a = CreateObject("scripting.filesystemobject")   '若是使用引用则这句可不用
    Set c = a.GetFolder(bc)
    For Each fl In c.Files
    
        If (fl.Type = "Microsoft Word 文档") And InStr(fl, "~$") = 0 Then
            co.Add fl
        End If
    Next
        Do While c.SubFolders.Count > 0
            For Each D In c.SubFolders
            st = st & D & ";"
            m = m + 1
                For Each bb In D.Files
                
        If (bb.Type = "Microsoft Word 文档") And InStr(bb, "~$") = 0 Then
            co.Add bb
        End If
                Next
            Next
        Loop
        For Each ss In co
            Debug.Print ss
        Next
        MsgBox "已完成！!!", vbOKCancel, "程序处理"
End Sub

猜你喜欢