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

  

VBA7种遍历方法的更多相关文章

  1. javase-常用三种遍历方法

    javase-常用三种遍历方法 import java.util.ArrayList; import java.util.Iterator; import java.util.List; public ...

  2. Java中Map的三种遍历方法

    Map的三种遍历方法: 1. 使用keySet遍历,while循环: 2. 使用entrySet遍历,while循环: 3. 使用for循环遍历.   告诉您们一个小秘密: (下↓面是测试代码,最爱看 ...

  3. Jquery中each的三种遍历方法

    Jquery中each的三种遍历方法 $.post("urladdr", { "data" : "data" }, function(dat ...

  4. java 完全二叉树的构建与四种遍历方法

    本来就是基础知识,不能丢的太干净,今天竟然花了那么长的时间才写出来,记一下. 有如下的一颗完全二叉树: 先序遍历结果应该为:1  2  4  5  3  6  7 中序遍历结果应该为:4  2  5 ...

  5. HashMap的四种遍历方法,及效率比较(简单明了)

    https://yq.aliyun.com/ziliao/210955 public static void main(String[] args) { HashMap<Integer, Str ...

  6. Dictionary 的几种遍历方法

    Dictionary 的几种遍历方法 Dictionary<string, int>dic = newDictionary<string, int>(); 方法1 foreac ...

  7. Java List /ArrayList 三种遍历方法

    java list三种遍历方法性能比较http://www.cnblogs.com/riskyer/p/3320357.html JAVA LIST 遍历http://blog.csdn.net/lo ...

  8. 2017.10.25 Java List /ArrayList 三种遍历方法

    java list三种遍历方法性能比较 学习java语言list遍历的三种方法,顺便测试各种遍历方法的性能,测试方法为在ArrayList中插入记录,然后遍历ArrayList,测试代码如下: pac ...

  9. 谈谈vector容器的三种遍历方法

    说明:本文仅供学习交流.转载请标明出处.欢迎转载!          vector容器是最简单的顺序容器,其用法相似于数组.实际上vector的底层实现就是採用动态数组.在编敲代码的过程中.经常会变量 ...

随机推荐

  1. html中引入另一个html文件

    https://segmentfault.com/q/1010000002954318

  2. window.history.go(-1);

    history是你浏览过的网页的url(简单的说就是网址)的集合,也就是你的浏览器里的那个历史记录.它在js里是一个内置对象,就跟document一样,它有自己的方法,go就是其中一个. 这个方法的参 ...

  3. bzoj2501

    题解: 显然,每当进入一个小的边界,那么我们的ans+1,出去一个大的边界,ans-1 然后,我们将每一个边界排序,时间小的在前,大的在后 每一次进来一个,如果是左边的边界,+1,右边的-1 然后输出 ...

  4. PHP for循环的写法和示例

    For循环是最近的循环语句之一,无论哪种语言,都有这个循环语句,也是我们工作中常用的循环方法. 语法规则: for (expr1; expr2; expr3){ 要执行的代码 } expr1:表示循环 ...

  5. JSON数组字典解析

    遇到这样的字典数组字符串 priceRange = "[{\"id\":149075584861800,\"price\":9.9,\"nu ...

  6. java集合运算:求交集,并集,集合差

    今天突然想用Java实现如何用集合实现交集,并集和差集的运算了!主要是看Python语言的时候想起来的. 实现主要使用的Set集合,Set集合的特点是集合内的元素不可重复. 具体代码如何: packa ...

  7. Dom4j下载及使用Dom4j读写XML简介(转)

    Dom4j下载及使用Dom4j读写XML简介 要使用dom4j读写XML文档,需要先下载dom4j包,dom4j官方网站在 http://www.dom4j.org/目前最新dom4j包下载地址:ht ...

  8. 编写configure.ac

    configure.ac由一些宏组成(如果已经有源代码,你可以运行autoscan来产生一个configure.scan文件,在此基础修改成configure.ac将更加方便) 最基本的组成可以是下面 ...

  9. Python读取UTF-8编码文件并使用命令行执行时输出结果的问题

    最近参加了由CCF举办的数据挖掘比赛,主办方提供了csv格式的数据文件,由于中文显示乱码的问题,我先用txt文本编辑器将编码改为utf-8格式,但是在读取文件并输出读取结果时发生了问题,代码如下: # ...

  10. mac svn: E210004: Number is larger than maximum

    SVN服务器IP地址发现改变,在Eclipse中的SVN资源库中执行Relocate重定位时发生错误: mac svn: E210004: Number is larger than maximum ...