Duplicating a complex folder structure with only shortcuts

Question

There are 2 shared drives. One of them has a very complex folder structure. I would like to replicate the entire folder structure of Share 1 to Share 2. However I don't want to make duplicate files, rather I would want a shortcut or symbolic links to be present in the 2nd share. I tried to do this with existing tools like Robocopy and mklink and failed to achieve the result. Any Ideas to resolve this issue is highly appreciated.

Answer 1

You can do achieve this by Using the filesystemobject to work it's way down the folder structure, if the folder exists in the destination, do nothing and create shortcuts in that folder for all the hosting folders files. Otherwise, create the folder and create the shortcuts for the hosting files anyway.

The DoFolder sub widdles it's way down through all the subfolders. The GetFN Function collects only the filenames of all the files in the hosting folder. Even if there are periods in the filename.

This was a fun program to write, thanks.

FolderShadows.vbs

Dim fso, HostFolder, DestFolder

'Host Folder - Folder must exist. 
HostFolder = "C:\From\Folder"

'Destination Folder - Folder must exist. 
DestFolder = "D:\To\Folder"

Set fso = CreateObject("Scripting.FileSystemObject")
DoFolder fso.GetFolder(HostFolder)
Sub DoFolder(Folder)
    Dim SubFolder
    If fso.folderexists(Replace(fso.GetAbsolutePathName(Folder), HostFolder, DestFolder)) = False Then
        fso.createfolder(Replace(fso.GetAbsolutePathName(Folder), HostFolder, DestFolder))
    End If
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        Dim FileName, shortcut
        If (fso.fileexists(Replace(fso.GetAbsolutePathName(Folder), HostFolder, DestFolder) & "\" & GetFN(File.Name) & ".lnk") = False) Then
            FileName = Replace(fso.GetAbsolutePathName(Folder), HostFolder, DestFolder) & "\" & GetFN(File.Name) & ".lnk"
            Set shortcut = CreateObject("WScript.Shell").CreateShortcut(FileName)
            shortcut.Description = "Shortcut To " & File.Name
            shortcut.TargetPath = fso.GetAbsolutePathName(Folder) & "\" & File.Name
            shortcut.Save
        End If
    Next
End Sub
Function GetFN(FileName)
    Dim Result, i
    Result = FileName
    i = InStrRev(FileName, ".")
    If ( i > 0 ) Then
        Result = Mid(FileName, 1, i - 1)
    End If
    GetFN = Result
End Function

Note: This script can run on an automated schedule, as it is built to auto update the shortcuts and folders if new files/folders are found.