'Creates zero-byte copies of an entire directory tree

Option Explicit

Main

Sub Main()
Dim fs, strSource, strDest
    Set fs = CreateObject("Scripting.FileSystemObject")
    'Get and verify input arguments (source and destination folders)
    If WScript.Arguments.Count > 2 Then
        Help
        Exit Sub
    End If
    'Get source
    If WScript.Arguments.Count > 0 Then
        strSource = WScript.Arguments(0)
    Else
        strSource = BrowseForFolder("Select source folder") 
    End If
    If Not fs.FolderExists(strSource) Then
        MsgBox "The source folder """ & strSourceFolder & """ does not exist."
        Exit Sub
    End If
    'Get destination
    If WScript.Arguments.Count = 2 Then
        strDest = WScript.Arguments(1)
    Else
        strDest = BrowseForFolder("Select destination folder") 
    End If
    If Not fs.FolderExists(strDest) Then
        MsgBox "The destination folder """ & strSourceFolder & """ does not exist."
        Exit Sub
    End If
    RecurseFiles strSource, strDest
End Sub

Sub RecurseFiles(strSource, strDest)
Dim ts, fs, fils, fil, fol, fols, strFolder
Const ForWriting = 2
    Set fs = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    'Be sure the destination folder exists
    If Not fs.FolderExists(strDest) Then
        fs.CreateFolder strDest
    End If
    'Check all the source files
    Set fils = fs.GetFolder(strSource).Files
    If Err.Number <> 0 Then Exit Sub
    'Create the zero-byte destination files
    For Each fil In fils
        Status fil.Path
        Set ts = fs.OpenTextFile(fs.BuildPath(strDest, fil.Name), ForWriting, True)
        ts.Close
    Next
    'Check for any sub folders and recursively process them
    Set fols = fs.GetFolder(strSource).SubFolders
    For each fol in fols
        If Lcase(fol.Name) <> "recycled" Then
            RecurseFiles fol.Path, fs.GetAbsolutePathName(fs.BuildPath(strDest, fol.Name))
        End If
    Next
End Sub

Sub Help()
Dim strAlert
    strAlert = "This script will create a zero-byte mirror of a folder. You "
    strAlert = strAlert & "can pass a source and destination folder "
    strAlert = strAlert & "as arguments. If you don't supply arguments, "
    strAlert = strAlert & "you'll be prompted for them. For example:" & vbCrLf
    strAlert = strAlert & WScript.ScriptName & " ""C:\source"" ""C:\dest""" & vbCrLf
    strAlert = strAlert & "would copy everything in and under the C:\source "
    strAlert = strAlert & "folder into the C:\dest folder -- except that all "
    strAlert = strAlert & "files created in the C:\dest folder would be zero "
    strAlert = strAlert & "bytes in size." 
    WScript.Echo strAlert
End Sub

Function BrowseForFolder(strPrompt)
'Uses the "Shell.Application" (only present in Win98 and newer)
'to bring up a file/folder selection window. Falls back to an
'ugly input box under Win95.
'Shell32.ShellSpecialFolderConstants
Const ssfPERSONAL = 5 'My Documents
Const ssfDRIVES = 17 'My Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2 
    Dim sh, fol, fs, lngView, strPath
    Set sh = CreateObject("Shell.Application")
    If Instr(TypeName(sh), "Shell") = 0 Then
    	BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName))
    	Exit Function
    End If
    Set fs = CreateObject("Scripting.FileSystemObject")
    lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
    strPath = ""
    Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
    Err.Clear
    On Error Resume Next
    strPath = fol.ParentFolder.ParseName(fol.Title).Path
    'An error occurs if the user selects a drive instead of a folder
    If Err.Number <> 0 Then
        BrowseForFolder = Left(Right(fol.Title, 3), 2) & "\"
    Else
        BrowseForFolder = strPath
    End If
End Function

Sub Status(strMessage)
    If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
        Wscript.Echo strMessage
    End If
End Sub