Sub遍历()For Each F In Dir遍历 'Office2003遍历,FSO遍历,双字典遍历,CMD遍历,栈遍历,管道遍历,Dir遍历

'此处加入文件处理代码即可。

Selection.InsertAfter F & Chr(13)

i= i + 1

NextSelection.InsertAfter iMsgBox "OKOK!!!", vbOKOnly, "OKKO"

End Sub

Sub单个文档处理(F)Dim pa As Paragraph, c AsRangeWith Documents.Open(F, Visible:=False)For Each pa In.ParagraphsFor Each c Inpa.Range.CharactersIf c.Font.Name = "仿宋" And Abs(Asc(c)) > 128 Thenc.Font.Name= "仿宋_GB2312"

ElseIf c.Font.Name = "仿宋" And Abs(Asc(c)) < 128 Thenc.Font.Name= "Times New Roman"

End If

Next

Next.CloseTrue

End With

End Sub

'遍历文件夹

FunctionCMD遍历()DimarrDim t: t =TimerWithApplication.FileDialog(msoFileDialogFolderPicker)'.InitialFileName = "D:\" '若不加这句则打开上次的位置

If .Show <> -1 Then Exit Functionfod=.InitialFileNameEnd WithCMD遍历文件 arr, fod,"*.doc*"arr= Filter(arr, "*", False, vbTextCompare)

CMD遍历=arrEnd Function

Function栈遍历()Dim arr() As String

Dim t: t =TimerWithApplication.FileDialog(msoFileDialogFolderPicker)If .Show <> -1 Then Exit Functionfod=.InitialFileNameEnd With遍历栈 arr,CStr(fod), "doc*", True '这种方式就不用使用Function在函数中返回了

栈遍历 =arrEnd Function

Function管道遍历()Dim t: t =TimerDim a As NewDosCMDDimarrWithApplication.FileDialog(msoFileDialogFolderPicker)If .Show <> -1 Then Exit Functionfod=.InitialFileNameEnd Witha.DosInputEnviron$("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文档

WithApplication.FileDialog(msoFileDialogFilePicker)

.Filters.Add"选择03版word文档", "*.doc", 1.Filters.Add"所有文件", "*.*", 2

If .Show <> -1 Then Exit Function

For Each F In.SelectedItemsIf InStr(F, "$") = 0 Thenstr0= str0 & F & Chr(13)End If

Next

End WithAllName= Left(str0, Len(str0) - 1)End Function

Function AllFodName() '用dos命令遍历选定文件夹下的所有word文档

Dim fso As Object

Dim aCollection As NewCollectionSet fso = CreateObject("scripting.filesystemobject")WithApplication.FileDialog(msoFileDialogFolderPicker)

.Title= "选择文档所在文件夹"

If .Show <> -1 Then Exit Functionfolder= .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, TrueOpen"C:\temp.txt" For Input As #1arr= Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)

Close #1ws.RunEnviron$("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 =arrEnd Function

Function FSO遍历() '我的得意代码之十五！！！文档不引用'*------------------------------------------------------------------------------*

Dim fso As Object, b As Object, arr() As String, F '注意,这里的as string是必须,否则,filter函数无法使用。因为收集的不是字符串形式的地址

Set fso = CreateObject("scripting.filesystemobject")WithApplication.FileDialog(msoFileDialogFolderPicker)If .Show <> -1 Then Exit Functionfod=.InitialFileNameEnd With

For Each F In fso.GetFolder(fod).Files '目录本身的

ReDim Preservearr(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遍历 =arrSet fso = Nothing

End Function

Function 查找子目录(ByVal fod As String, arr, fso)If fso.FolderExists(fod) Then

If Len(fso.GetFolder(fod)) = 0 ThenDebug.Print"文件夹" & fod & "是空的！" '这里似乎用不上

Else

For Each zi Infso.GetFolder(fod).SubFoldersFor Each F In zi.Files '子目录中的

i = UBound(arr) + 1

ReDim Preservearr(i)

arr(i)=FNext查找子目录 zi, arr, fsoNext

End If

End If

End Function

FunctionDir遍历()Dim arr() As String

WithApplication.FileDialog(msoFileDialogFolderPicker)If .Show <> -1 Then Exit Functionfod=.InitialFileNameEnd With处理子目录 fod, arr

arr= Filter(arr, ".doc", True, vbTextCompare) '仅保留doc文件

arr = Filter(arr, "$", False, vbTextCompare) '过滤掉带有$符号的文件

Dir遍历 =arrEnd 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 OrvbReadOnly)Do While MY <> ""

If MY <> ".." And MY <> "." Then

If (GetAttr(p + MY) And vbDirectory) = vbDirectory Thenn= n + 1

ReDim Preserveb(n)

b(n- 1) =MYElse

On Error Resume Nexti= UBound(arr) + 1

On Error GoTo 0

ReDim Preservearr(i)

arr(i)= p +MYEnd If

End IfMY= Dir

Loop

For j = 0 To n - 1处理子目录 (p+b(j)), arrNext

ReDim b(0)End Sub

Function Office2003遍历() '-------------参考

Dim sFile As String, arr() As String

WithApplication.FileDialog(msoFileDialogFolderPicker)'.InitialFileName = "D:\" '若不加这句则打开上次的位置

If .Show <> -1 Then Exit Functionbc=.InitialFileNameEnd With

Set mySearch = Application.FileSearch '定义一个Application.FileSearch

WithmySearch

.NewSearch'设置一个新搜索

.LookIn = bc '在该驱动器盘符下

.SearchSubFolders = True '搜索子文件夹

'.FileType = msoFileTypeWordDocuments '以此可以定义文件类型

.FileName = "*.DOc*" '搜索一个指定文件，此处为任意WORD模板文件

If .Execute() > 0 Then '开始并搜索成功

For i = 1 To.FoundFiles.CountReDim Preserve arr(i - 1)

arr(i- 1) =.FoundFiles(i)NextiEnd If

End WithOffice2003遍历=arrEnd Function

Function 双字典遍历() '字典分为word的dictionary和scripting的dictionary，这里的是后者。

Dim d1, d2 'as Dictionary

Set d1 = CreateObject("scripting.dictionary")Set d2 = CreateObject("scripting.dictionary")WithApplication.FileDialog(msoFileDialogFolderPicker)'.InitialFileName = "D:\" '若不加这句则打开上次的位置

If .Show <> -1 Then Exit Functionpath1=.InitialFileNameEnd Withd1.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 IfML= Dir()Loopi= i + 1

Loop

'*---------------------------第二个字典获取各个目录的文件名----------------------------*

For Each ke Ind1.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.keysSet d1 = Nothing

Set d2 = Nothing

End Function

Function CMD遍历文件(ByRef arr, ByVal aPath$, ByValaExtensionName$)DimaNum%Dim t: t =TimerWith CreateObject("WScript.Shell")If Right(aPath, 1) <> "\" Then aPath = aPath & "\".RunEnviron$("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 Witharr= 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 Totop)Do While top >= 1DirFile= Dir(pPath1, vbDirectory)Do While DirFile <> ""

If DirFile <> "." And DirFile <> ".." Then

If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Thenmf= mf + 1

ReDim Preserve mlNameArr(1 Tomf)

mlNameArr(mf)= pPath1 &DirFileEnd If

End IfDirFile= Dir

Loop

If pSub = False Then Exit FunctionDirFile= Dir(pPath1, vbDirectory) '搜索子目录

Do While DirFile <> ""

If DirFile <> "." And DirFile <> ".." Then

If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory ThenworkStack(top)= pPath1 & DirFile & "\" '压栈

top = top + 1

If top > UBound(workStack) Then ReDim Preserve workStack(0 Totop)End If

End IfDirFile= 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 Totop)Do While top >= 1DirFile= Dir(pPath1 & "*." &pMask)Do While DirFile <> ""mf= mf + 1

ReDim Preserve fileNameArr(1 Tomf)

fileNameArr(mf)= pPath1 &DirFile

DirFile= Dir

Loop

If pSub = False Then Exit FunctionDirFile= Dir(pPath1, vbDirectory) '搜索子目录

Do While DirFile <> ""

If DirFile <> "." And DirFile <> ".." Then

If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory ThenworkStack(top)= pPath1 & DirFile & "\" '压栈

top = top + 1

If top > UBound(workStack) Then ReDim Preserve workStack(0 Totop)End If

End IfDirFile= Dir 'next file

Loop

If top > 0 Then pPath1 = workStack(top - 1): top = top - 1 '弹栈

Loop

End Function