banner
李大仁博客

李大仁博客

天地虽大,但有一念向善,心存良知,虽凡夫俗子,皆可为圣贤。

VBS实现目录下所有文件归集

一个简单的需求: Windows 环境下用 VBS/VBA 来实现抽取某一个特定目录下的全部所有文件,要求遍历当前目录下所有的子目录。 注意各子目录下文件的文件名可能会重复,各子目录下存在空目录的情况。

实现 VBS 代码

' 需要遍历的目录路径
dim strDirPath = "c:\dir"

' 遍历目录
Private Sub FileTree(strPath)
Set obFso = CreateObject("Scripting.FileSystemObject")
If obFso.FolderExists(strPath) Then
Set obFolder = obFso.GetFolder(strPath)
' 遍历当前目录下的所有目录,递归调用
Set obSubFolders = obFolder.SubFolders
For Each obSubFolder In obSubFolders
Call FileTree(obSubFolder.Path & "")
Next
' 剔除当前目录
If strPath = Trim(strDirPath) Then
Exit Sub
End If
' 遍历当前目录下的所有文件
Set obFiles = obFolder.Files
For Each obFile In obFiles
Call ExcuteFolderConcentrate(obFile.Path & "")
Next
Else
MsgBox "无效路径"
Exit Sub
End If
End Sub

' 文件归集操作
Private Sub ExcuteFolderConcentrate(strPath)
Set obFso = CreateObject("Scripting.FileSystemObject")
If obFso.FileExists(strPath) Then
fullPath = Trim(strDirPath) & "\"
' 按目录层级设置新文件名
newFileName = Replace(Right(strPath, Len(strPath) - Len(fullPath)), "\", "_")
' 重复文件重新命名
If obFso.FileExists(fullPath & newFileName) Then
Call obFso.copyFile(strPath, fullPath & newFileName & ".duplicate")
Else
Call obFso.copyFile(strPath, fullPath & newFileName)
End If
End If
End Sub

' 遍历整个目录,完成文件归集
FileTree (strDirPath)
' 重新打开目录文件夹
CreateObject("Shell.Application").Explore strDirPath

加载中...
此文章数据所有权由区块链加密技术和智能合约保障仅归创作者所有。