|
|
前不久看到的，看有不有用！
VBA 7种遍历方法：
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
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-10-30 21:35
楼主
