Xmind create touch file version of files and folder structure to recreate directory structure VBS
This VBS creates a touch folder (zero byte) version of a file/folder structure so it can be dropped (copied) into xmind.
ZeroTouchFileFolder.vbs
Option Explicit
StartZTF ''Zero Touch Files & Folder Replication for folder structure reference
Sub StartZTF()
Dim CopyStructPath 'as String
Dim FileCt 'as Integer
Dim FolderCT 'as Integer
Dim FSO 'as New FileSystemObject
set FSO = CreateObject("Scripting.FileSystemObject")
dim FolderDepth ''limit recurse depth of folders
''msgbox Wscript.Arguments(0)
CopyStructPath = Wscript.Arguments(0) ''"C:\ProgramData\KTGY\ACACustom" ''String to filestruct to copy
FolderDepth = InputBox("Limit depth of folders to grab, -1 for unlimited: " ,"Limit folder depth" , -1 )
FolderDepth = FolderDepth + 1
Dim strLFP 'as String
''BASE FOLDER PATH:
strLFP = "C:\temp\QCT\" & replace(Replace(FSO.GetFolder(CopyStructPath).Path, ":\", "_", 1, 1),"\","_")
MkSubDir FSO, strLFP
QCT FSO.GetFolder(CopyStructPath), FSO.GetFolder(strLFP), FolderDepth
msgbox Wscript.Arguments(0) & " Complete", vbokonly, "Completed"
End Sub
Sub QCT(ByVal FP, ByVal strLFP, ByVal FolderDepth)
Dim SubFolder 'as Folder
Dim ss 'as Folder
Call CreateFiles(FP, strLFP)
FolderDepth = FolderDepth -1
if FolderDepth = 0 then exit sub
For Each SubFolder In FP.SubFolders
''strSFN = strLFP & "\" & SubFolder.Name
On Error Resume Next
Set ss = Nothing
Set ss = strLFP.SubFolders.Item(SubFolder.Name)
On Error GoTo 0
If ss Is Nothing Then strLFP.SubFolders.add (SubFolder.Name)
QCT SubFolder, strLFP.SubFolders.Item(SubFolder.Name), FolderDepth
Next ''SubFolder
End Sub
Sub CreateFiles(ByRef FP, ByRef strLFP)
Dim ObjFile 'as File
For Each ObjFile In FP.Files
strLFP.CreateTextFile(ModFN(ObjFile.Name, ObjFile.Size)).Close
Next ''ObjFile
End Sub
Private Function ModFN(FN, FS) 'as String
Dim fExt 'as String
Dim I 'as Integer
Dim strU 'as String
Dim intU 'as Integer
For I = Len(FN) To 1 Step -1
If Mid(FN, I, 1) = "." Then Exit For
Next ''I
If I > 1 Then
fExt = Trim(Mid(FN, I, 32)) 'trim long mid over to end up to 32 characters
''else ther was no "." in the filename
FN = left(FN, I - 1)
End If
intU = 1
If FS >= 1000000000 Then
intU = 1000000000
strU = "TB"
ElseIf FS >= 1000000 Then
intU = 1000000
strU = "MB"
ElseIf FS >= 1000 Then
intU = 1000
strU = "KB"
Else
intU = 1
strU = "B"
End If
ModFN = FN & " [" & int(FS / intU*10)/10 & " " & strU & "]" & fExt
End Function
Sub MkSubDir(FSO, FP)
Dim x
Dim fps
Dim I, ub 'as Integer
x = Split(FP, "\")
ub = -1
On Error Resume Next: ub = UBound(x): On Error GoTo 0
For I = 0 To ub
fps = fps & x(I) & "\"
If Not FSO.FolderExists(fps) Then FSO.CreateFolder (fps)
Next ''I
End Sub
Comments
Post a Comment