批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程
[批处理文件精品]批处理版照片整理器[批处理文件精品]纯批处理备份&还原驱动在线第三方下载
返回列表 发帖

[原创] VBS脚本模拟tree命令:vbsTree


'-------------vbsTree.vbs------------------------
'描述:用vbs输出一个文件夹的目录结构。
'------------------------------------------------
Const Unit4Size = "字节KBMBGB"
Const OutFile = "OutTree.txt"
Dim theApp,SelPath,TreePath,TreeStr
Set theApp = CreateObject("Shell.Application")
Set SelPath = theApp.BrowseForFolder(0,"请选择需要列出子项目的路径",0)
If SelPath Is Nothing Then WScript.Quit
TreePath = SelPath.items.Item.Path
Set SelPathPath = Nothing
Set
theApp = Nothing
Dim
objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
TreeStr = TreePath & FormatSize(objFSO.GetFolder(TreePath).Size) & vbCrLf
Tree TreePath,""
Set objFile = objFSO.CreateTextFile(OutFile,True)
objFile.Write TreeStr
objFile.Close
Set
objFile = Nothing
Set
objFSO = Nothing
MsgBox
"查看当前目录下的OutTree.txt",vbInformation,"完成 - vbsTree"
Sub Tree(Path,SFSpace)
   
Dim i,TempStr,FlSpace
    FlSpace = SFSpace & "  "
    Set CrntFolder = objFSO.GetFolder(Path)
   
i = 0:TempStr = "├─"
    For Each ConFile In CrntFolder.Files
        i = i + 1
        If i = CrntFolder.Files.Count And CrntFolder.SubFolders.Count = 0 Then TempStr = "└─"
        TreeStr = TreeStr & FlSpace & Tempstr & ConFile.name & FormatSize(ConFile.size) & vbCrLf
    Next
   
i = 0:TempStr = "├─"
    For Each SubFolder In CrntFolder.SubFolders
        i = i + 1
        If i = CrntFolder.SubFolders.Count Then
            
TempStr = "└─"
            SFSpace = FlSpace & "  "
        Else
            
SFSpace = FlSpace & ""
        End If
        
TreeStr = TreeStr & FlSpace & TempStr & SubFolder.name & FormatSize(SubFolder.size) & vbCrLf
        
Tree SubFolder,(SFSpace)
   
Next
End Sub
Function
FormatSize(SZ)
   
Dim i
    Do While SZ > 1024
        i = i + 1
        SZ = SZ \ 1024
    Loop
   
FormatSize = "  (" & SZ & Mid(Unit4Size,1 + 2 * i,2) & ")"
End Function


自己测试下效果看看~
3

评分人数

    • fastslz: 感谢分享PB + 10 技术 + 1
    • rat:PB + 30 技术 + 1
    • Batcher: 感谢分享PB + 11 技术 + 1

我把文件夹浏览部分优化下
  1. '-------------vbsTree.vbs------------------------
  2. '描述:用vbs输出一个文件夹的目录结构。
  3. '------------------------------------------------
  4. Const Unit4Size = "字节KBMBGB"
  5. Const OutFile = "OutTree.txt"
  6. Dim TreePath,TreeStr,WS
  7. Set WS = WScript.CreateObject("WScript.Shell")
  8. TreePath = BFF("请选择需要列出子项目的路径",&H0001 + &H0008 + &H0010,"")
  9. Set WS = Nothing
  10. If Len(TreePath) = 0 Then WScript.Quit
  11. If Len(TreePath) <= 3 Then MsgBox "无法处理根目录!",64,"提示":WScript.Quit
  12. Dim objFSO
  13. Set objFSO = CreateObject("Scripting.FileSystemObject")
  14. TreeStr = TreePath & FormatSize(objFSO.GetFolder(TreePath).Size) & vbCrLf
  15. Tree TreePath,""
  16. Set objFile = objFSO.CreateTextFile(OutFile,True)
  17. objFile.Write TreeStr
  18. objFile.Close
  19. Set objFile = Nothing
  20. Set objFSO = Nothing
  21. MsgBox "查看当前目录下的OutTree.txt",vbInformation,"完成 - vbsTree"
  22. Sub Tree(Path,SFSpace)
  23.     Dim i,TempStr,FlSpace
  24.     FlSpace = SFSpace & "  "
  25.     Set CrntFolder = objFSO.GetFolder(Path)
  26.     i = 0:TempStr = "├─"
  27.     For Each ConFile In CrntFolder.Files
  28.         i = i + 1
  29.         If i = CrntFolder.Files.Count And CrntFolder.SubFolders.Count = 0 Then TempStr = "└─"
  30.         TreeStr = TreeStr & FlSpace & Tempstr & ConFile.name & FormatSize(ConFile.size) & vbCrLf
  31.     Next
  32.     i = 0:TempStr = "├─"
  33.     For Each SubFolder In CrntFolder.SubFolders
  34.         i = i + 1
  35.         If i = CrntFolder.SubFolders.Count Then
  36.             TempStr = "└─"
  37.             SFSpace = FlSpace & "  "
  38.         Else
  39.             SFSpace = FlSpace & "│"
  40.         End If
  41.         TreeStr = TreeStr & FlSpace & TempStr & SubFolder.name & FormatSize(SubFolder.size) & vbCrLf
  42.         Tree SubFolder,(SFSpace)
  43.     Next
  44. End Sub
  45. Function FormatSize(SZ)
  46.     Dim i
  47.     Do While SZ > 1024
  48.         i = i + 1
  49.         SZ = SZ \ 1024
  50.     Loop
  51.     FormatSize = "  (" & SZ & Mid(Unit4Size,1 + 2 * i,2) & ")"
  52. End Function
  53. Function BFF(title, flag, dir)
  54. On Error Resume Next
  55. Dim oShell, oItem, oStr
  56. Set oShell = WScript.CreateObject("Shell.Application")
  57. Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
  58. oStr = oItem.Title
  59. If Err <> 0 Then
  60.     Set oShell = Nothing
  61.     Set oItem = Nothing
  62.     Exit Function
  63. End If
  64. If InStr(oStr, ":") Then
  65. BFF = mid(oStr,InStr(oStr, ":")-1, 2)
  66.     Else
  67.         Select Case oStr
  68.             Case "桌面"
  69.                 BFF = WS.SpecialFolders("Desktop")
  70.             Case "我的文档"
  71.                 BFF = WS.SpecialFolders("MyDocuments")
  72.             Case "我的电脑"
  73.                 MsgBox "无效目录!",64,"提示":WScript.Quit
  74.             Case "网上邻居"
  75.                 MsgBox "无效目录!",64,"提示":WScript.Quit
  76.             Case Else
  77.              BFF = oItem.ParentFolder.ParseName(oItem.Title).Path
  78.         End Select
  79.     End If
  80. Set oShell = Nothing
  81. Set oItem = Nothing   
  82. If Right(BFF,1)<> "\" Then
  83.     BFF = BFF & "\"
  84. End If
  85. On Error GoTo 0
  86. End Function
复制代码

TOP

根目录是可以遍历的……

对了,要更新copy下cn-dos那个吧,那个做了点修改。

TOP

回复 2# fastslz


    无法作用于中文目录啊。。。

TOP

返回列表