Sub ListFilesTest()
'-----------------文件夹内含有子文件夹操作
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
Application.AskToUpdateLinks = False '不更新链接
Application.DisplayAlerts = False '不提示窗口
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
' [a:b] = "" '清空A列
Call ListAllFso(myPath) '调用FSO遍历子文件夹的递归过程
Application.EnableEvents = True
Application.ScreenUpdating = True '恢复屏幕刷新
Application.AskToUpdateLinks = True '更新链接
Application.DisplayAlerts = True '提示窗口
Application.Calculation = xlCalculationAutomatic '恢复自动重算
MsgBox "已完成"
End Sub
Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
On Error Resume Next
Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
'用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】
ad = fld.Path
For Each f In fld.Files '遍历当前文件夹内所有【文件.Files】
' [a65536].End(3).Offset(1) = f.Name '在A列逐个列出文件名
Set Wb = Workbooks.Open(Filename:=ad & "" & f.Name) '打开文件操作
For Each m In Wb.VBProject.VBComponents
If m.Name Like "*" Then
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If
Next m
Wb.Close savechanges:=True '保存并关闭
Next f
For Each fd In fld.SubFolders '遍历当前文件夹内所有【子文件夹.SubFolders】
ad2 = fd.Path
na2 = fd.Name
' [a65536].End(3).Offset(1) = " " & fd.Name & "" '在A列逐个列出子文件夹名
Call ListAllFso(fd.Path) '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
'注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
Next fd
End Function