jkluio668
6/2/2018 - 7:25 PM
dir 遍历
遍历文件夹。 获取路径的文件名、扩展名。
'Office2003遍历,FSO遍历,双字典遍历,CMD遍历,栈遍历,管道遍历,Dir遍历
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 双字典遍历() ' 字典分为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
[1]拆分文件名和扩展名
获取文件名和扩展名，可以使用VBA语句和FSO对象模型两种方式。
1 使用VBA语句拆分文件名和扩展名
Function SplitFilename(ByVal sFileName As String) As Variant
Dim aRet(1 To 3) As String
Dim i As Integer
i = InStrRev(sFileName, "")
aRet(1) = Left(sFileName, i)
sFileName = Mid(sFileName, i + 1)
i = InStrRev(sFileName, ".")
aRet(2) = Left(sFileName, i - 1)
aRet(3) = Mid(sFileName, i + 1)
SplitFilename = aRet
End Function
Sub 分离文件名()
Dim sFileName As String, aRet As Variant
sFileName = Application.GetOpenFilename(, , "选择源文件")
If sFileName = "False" Then Exit Sub '用户选择"取消"则退出程序
aRet = SplitFilename(sFileName)
MsgBox "路径：" & aRet(1) & vbNewLine & _
"文件名：" & aRet(2) & vbNewLine & _
"扩展名：" & aRet(3)
End Sub
2 使用FSO对象模型拆分文件名和扩展名
Sub FSO分离文件名()
Dim fso As New FileSystemObject, sFileName As String
Dim str1 As String
If sFileName = "False" Then Exit Sub
MsgBox "路径：" & fso.GetParentFolderName(sFileName) & vbNewLine & _
"文件名：" & fso.GetBaseName(sFileName) & vbNewLine & _
"扩展名：" & fso.GetExtensionName(sFileName)
Set fso = Nothing
-End-