Home > 语言编程, 零敲碎打 > VBS实现目录下所有文件归集

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

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

实现VBS代码

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
'需要遍历的目录路径
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 "Invalide Path"
        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
Categories: 语言编程, 零敲碎打 Tags: ,
  1. No comments yet.
  1. No trackbacks yet.