VBA获取全部文件方案二

'    﨩  龥'    﨩  龥'    﨩  龥  ★★★★★★★★★★★★★★★★★★★★★★★★☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'If .Range Like "[" & Chr$(9) & ChrW(-24159) & Chr$(11) & Chr$(13) & Chr$(32) & "]"
'使用通配符替换的情况：ActiveDocument.Range.Find.Execute "", , , 2, , , , , , "", 2   ’最后一个2代表全部替换,改成1为仅替换一次。
'未使用的情况: ActiveDocument.Range.Find.Execute "", , , 0, , , , , , "", 2   '说明：第一个0代表非通配符模式，1或2代表使用。
'使用通配符替换的情况：selection.Find.Execute "", , , 2, , , , , , "", 2
'未使用的情况: Selection.Find.Execute "", , , 0, , , , , , "", 2
'     .Text = "[0-9]@[" & ChrW(&H20) & ChrW(&H3000) & ChrW(&HA0) & ChrW(&H2E) & "]{1,}"
'提纲:
'1.编写将所有模块自动添加到一个总的文档的代码。省的一个一个去复制粘贴。
Private Declare Function OpenProcess Lib "kernel32" _
                        (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
                        (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Const INFINITE = &HFFFFFFFF
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const SYNCHRONIZE = &H100000
Public aa As String
Sub 空格CMD外部路径() 'D:\1 23文件夹
    Dim returnvalue&, hProcess&
    returnvalue = Shell("cmd /c dir /b/s " & Chr(34) & "D:\1 23" & Chr(34) & ">c:\d.txt", vbMaximizedFocus) '去掉, vbMaximizedFocus则不显示cmd窗口
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION + SYNCHRONIZE, 0, returnvalue)
    WaitForSingleObject hProcess, INFINITE
    MsgBox "您结束了CMD外部程序！"
End Sub

Sub 循环遍历所有文件2()
aa = ""
子文件 ("D:\Desktop\16-17（1）期末考试材料【张磊】---SOP\123")
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.ParagraphFormat.TabStops.ClearAll
    .DefaultTabStop = CentimetersToPoints(0)
    .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 遍历处理doc()
    Dim returnvalue&, hProcess&
    lujing = "D:\Desktop\16-17（1）期末考试材料【张磊】---SOP\123\*.doc*"
    returnvalue = Shell("cmd /c dir /b/s " & Chr(34) & lujing & Chr(34) & ">c:\tem222.txt", 0) '去掉, vbMaximizedFocus则不显示cmd窗口
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION + SYNCHRONIZE, 0, returnvalue)
    WaitForSingleObject hProcess, INFINITE
    Open "c:\tem222.txt" For Input As #1
    ar = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1
    For i = 0 To UBound(ar)
     If InStr(ar(i), ".xls") > 0 Then
     
'*------------单个文件处理代码-------------*
With Documents.Open(CStr(ar(i)), Visible = True)
'    .Range.ParagraphFormat.TabStops.ClearAll
'    .DefaultTabStop = CentimetersToPoints(0)






    .Close True
End With
'*---------------------------------------*
     
     End If
    Next
   
     Shell "cmd /c del /q c:\tem222.txt", vbHide
End Sub
Sub 获取D盘中所有Excel文件2() '包括子目录
Dim sh As New WshShell, fd$, ar, st$, br, i&, n&, t
    With sh
        fd = .Environment("Process").Item("TEMP")
        st = .Exec("cmd.exe /c dir/s /a-d d:\*.xl* > %temp%\222.txt").StdOut.ReadAll
    End With
    Open fd & "\222.txt" For Input As #1
    ar = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1
    ReDim br(1 To UBound(ar), 1 To 2)
    For i = 0 To UBound(ar)
        If InStr(ar(i), "的目录") > 0 Then fd = Split(ar(i), "的目录")(0) & "\"
        If InStr(ar(i), ".xls") > 0 Then
            t = Split(ar(i), " ")
            n = n + 1
            br(n, 1) = t(0) & " " & t(2)
            br(n, 2) = fd & t(UBound(t))
        End If
    Next
    Range("a1").Resize(n, 2) = br
End Sub

'**************************************************************************************
Sub 字典替换实例() '*******
Dim d As Object, b, c  '****此处必须定义(可以为object或空)，而且不能定义为词典，否则出错
Set d = CreateObject("scripting.dictionary") 'Scripting.Dictionary
d.Add "狐狸", "4444"
d.Add "[^32^9　]@", ""
d.Add "^11", "^13"
d.Add "[^13]{1,}", "^p"
d.Add "[qQ]4", "b5"
b = d.keys
c = d.Items
For i = 0 To d.Count - 1
    'Debug.Print b(i) '****必须设置变量b，而不能用d.keys！
    'Debug.Print c(i)
Selection.Find.Execute findtext:=b(i), MatchCase:=False, MatchWildcards:=True, Wrap:=wdFindStop, _
ReplaceWith:=c(i), Replace:=wdReplaceAll '用_换行时前面需有空格方可！
'    Debug.Print d.Items(i)
Next
'另一种做法：For Each strKey In oDict.Keys
'Selection.Find.Execute FindText:=strKey, ReplaceWith:=oDict(strKey), Replace:=wdReplaceAll
Selection.StartOf wdStory '****不知何意
End Sub
Sub 数组替换实例()
Dim aa(), bb()
aa = Array("zs", "ls", "ww", "zl")
bb = Array("张三", "李四", "王五", "赵六")
For i = 0 To UBound(aa)
    Selection.Find.Execute findtext:=aa(i), MatchWildcards:=True, ReplaceWith:=StrConv(aa(i), vbUpperCase), _
    Wrap:=wdFindStop, Replace:=wdReplaceAll '---大写转换,亦可转换全半角
'    Selection.Find.Execute findtext:=aa(i), MatchWildcards:=True, replacewith:=bb(i), Wrap:=wdFindStop, Replace:=wdReplaceAll
Next '看来wrap不必放在replacewith前面也可以
End Sub
Sub 数组实例二()
    Dim myArray As Variant
    Dim oArray As Variant
    myArray = Array("那只", "敏捷", "的", "棕毛", "狐狸")
    Application.ScreenUpdating = False
    For Each oArray In myArray
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Wrap = wdFindStop
            .Text = oArray
            .Replacement.Text = Empty
            .Replacement.ClearFormatting
            .Replacement.Highlight = wdGray25
            .Execute Replace:=wdReplaceAll
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Sub 数组替换实例三()
Dim myRange As Range
    Set myRange = ActiveDocument.Content
    ARR = Array("张三", "陈离") '这里自己添加
    brr = Array("张丰", "陈高") '这里自己添加
    For i = LBound(ARR) To UBound(ARR)
        myRange.Find.Execute findtext:=ARR(i), ReplaceWith:=brr(i), Replace:=wdReplaceAll
    Next
End Sub
Sub 数组替换实例四()
Dim myFind() As String, MyRep() As String, i As Integer
    myFind = Split("色浆,色漿,银浆,銀漿,金粉,色精,珠光粉,闪片,閃片,助剂,助劑,色粉,力架,溶剂,溶劑,开油水,開油水,油漆,（,）,((,)), ", ",")
    MyRep = Split(" Color Paste, Color Paste, Silver Paste, Silver Paste, GoldenPowder, Color Concentrate, Pearl Pigment, Glitter, Glitter, Additive, Additive, Pigment, Lacquer, Solvent, Solvent, Thinner, Thinner, Paint,(,),(,),", ",")
    Application.ScreenUpdating = False
    For i = 0 To UBound(myFind)
        Selection.Find.Execute findtext:=myFind(i), ReplaceWith:=MyRep(i), Replace:=2
    Next
    Application.ScreenUpdating = True
End Sub
Sub 字符串替换实例()
On Error Resume Next '出现一般的错误时自动跳过
aa = "１２３４５６７８９"
bb = "0123456789" '数目十个，少了会出问题
c = Len(aa)
For i = 1 To c
m = Mid(aa, i, 1) '不可设置为这样：aa(i) = Mid(aa, i, 1)
n = Mid(bb, i, 1)
Selection.Find.Execute findtext:=m, ReplaceWith:=n, Replace:=wdReplaceAll
Next
End Sub
Sub 代码整理字典替换()
Dim s As Object, a, b
Set s = CreateObject("scripting.dictionary")
替换式 = "\1^p\2"
's.Add "(Dim)", 替换式
's.Add "(Next)", 替换式
's.Add "(End if)", 替换式
's.Add "(End function)", 替换式
's.Add "(loop)", 替换式
's.Add "(Do while)", 替换式
's.Add "(Set)", 替换式
's.Add "(End With)", 替换式
's.Add "(With)", 替换式
's.Add "(Selection)", 替换式
's.Add "(Do Until)", 替换式
's.Add "(MsgBox)", 替换式
s.Add "[ ]{4}", "^t"
s.Add "[ ]{2,}", "^t"
s.Add "([!^9])(^9)", "\1^p\2"
s.Add "^13^9'", "^t'"
'------------------------------------------------
s.Add "([ a-zA-Z\)])(Dim)", 替换式
s.Add "([ a-zA-Z\)])(Application.Screen)", 替换式
s.Add "([ a-zA-Z\)])(For Each)", 替换式
s.Add "([ a-zA-Z\)])(End Sub)", 替换式
s.Add "([ a-zA-Z\)])(End If)", 替换式
s.Add "([ a-zA-Z\)])(End Select)", 替换式  '上面三个换成s.Add "([ a-zA-Z\)])(End [A-Z]@)
s.Add "([ a-zA-Z\)])( Case)", 替换式
s.Add "([ a-zA-Z\)])(Exit For)", 替换式
s.Add "([a-ce-zA-CE-Z\)])( If)", 替换式
s.Add "([ a-df-zA-Z\)])(Next)", 替换式
s.Add "(End If)([ a-zA-Z\)])", 替换式
s.Add "([ a-zA-Z\)])(On[ ])", 替换式
s.Add "([ a-zA-Z\)])(Selection.)", 替换式
s.Add "(Next)([ a-zA-Z\)])", 替换式
s.Add "(.InlineShapes)([ a-zA-Z\)])", 替换式
s.Add "(+ 1)([ a-zA-Z\)])", 替换式
s.Add "([!^13a-zA-Z])( ActiveDocument.)", 替换式
s.Add "([一-龥])([ .]@[a-zA-Z\)])", 替换式
s.Add "([一-龥])([）\)]@)([ .]@[a-zA-Z\)])", "\1\2^p\3"
s.Add "(Explicit)([ ]@Sub)", 替换式
s.Add "([a-zA-Z\)])[ ]@(MsgBox)", 替换式
s.Add "([a-zA-Z\)])[ ]@(Call)", 替换式
s.Add "([a-zA-Z\)])[ ]@(Public)", 替换式
s.Add "(CreateObject\(*\)) ([!^13])", 替换式
s.Add "([a-zA-Z\-)])[ ]@(Private)", 替换式
'*-*--------------------------------------------------*
s.Add "([!^13])(End Function)([!'])", "\1^p\2^p\3"
s.Add "([!^13])(End If)([!'])", "\1^p\2^p\3"
s.Add "([!^13])(End With)([!'])", "\1^p\2^p\3"
s.Add "([!^13])(Debug.Print*)", "\1^p\2"
'*-*--------------------------------------------------*
s.Add "(Next)[ ^13]@([a-zA-Z]{1,3})", "\1 \2"
s.Add "([a-zA-Z\)])[^13 ]@(')", "\1  \2"
s.Add "([!^13]@)[ ]@(Set )", 替换式
s.Add "(On Error Resume[ ^13]@Next)", "On Error Resume Next"
a = s.keys
b = s.Items
For i = 0 To s.Count - 1
Debug.Print i
Selection.Find.Execute findtext:=a(i), MatchCase:=False, MatchWildcards:=True, Wrap:=wdFindStop, _
ReplaceWith:=b(i), Replace:=wdReplaceAll
Next
End Sub