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
