VBS - Duplicate Folder Structure

Armed with my folder browser script I finally finished rounding out my script to clone / duplicate a folder structure.

On occasion I produce a folder/directory structure which I’d like to be able to reuse as a template - e.g. on a project.  The problem is that it already has lots of files in and I have to copy the whole thing and then use an ‘open’ search to list the files in the new structure so that they can be deleted, but if there are lots of big files this operation can be slow and the inefficiency of it grates against my programmer’s nature.

Thus came about the writing of a little bit of VBScript to copy an existing folder structure and effectively clone it to another area on a file system.  So here’s the script … I hope you find it useful.

Option Explicit

Const ForReading = 1
Const ForWriting = 2
Const MAKE_FILE = "BuildFolders.txt"

Dim objFSO, objFolder, objFile
Dim strSourceFolder, strDestinationFolder, strBuildFoldersFile
Dim intFolders

'Initialise and capture folder paths
intFolders = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSourceFolder = SelectFolder("Select a source folder")
strDestinationFolder = SelectFolder("Select a destination folder")
strBuildFoldersFile = strDestinationFolder & "\" & MAKE_FILE

'Read, store and then build the new folder structure

MsgBox "Created " & intFolders & " folders", vbOKOnly & vbInformation, "Folder Generation complete"


'Read the source folder structure and store it
Sub CreateBuildFile()
    Set objFile = objFSO.CreateTextFile(strBuildFoldersFile, True)
End Sub

'Create the destination folder - should exist from the selection ... but just in case
'I (or someone else) wants to parameterise this script later on...
Sub CreatestrDestinationFolder()
    If Not objFSO.FolderExists(strDestinationFolder) Then
        intFolders = intFolders +1
    End If
End Sub

'Create the new folder structure
Sub MakeFromBuildFile()
    Set objFile = objFSO.OpenTextFile(strBuildFoldersFile, ForReading)
    Do While Not objFile.AtEndOfStream
        objFSO.CreateFolder(strDestinationFolder & objFile.ReadLine)
        intFolders = intFolders +1
End Sub

'Remove the file that was holding the data structure
Sub DeleteBuildFile()
End Sub

'Write a folder structure to the build file
Sub ReadstrSourceFolders(p_strSource)
    Dim colSubFolders
    Dim objSubFolder

    Set objFolder = objFSO.GetFolder(p_strSource)
    Set colSubfolders = objFolder.Subfolders
    For Each objSubfolder in colSubfolders
End Sub

'Remove the source folder path from a string (i.e. a sub folder's path)
Function StripstrSourceFolder(p_strFolder)
    StripstrSourceFolder = Right(p_strFolder,(Len(p_strFolder)-Len(strSourceFolder)))
End Function

'Select a folder
Function SelectFolder(pstrDialogLabel)
    'Select a folder
    Const BIF_returnonlyfsdirs   = &H0001
    Const BIF_editbox            = &H0010

    Dim objBrowseFolderDialog, objFolder, objFSO, objSelection
    Dim bBrowseForFolder

    Set objBrowseFolderDialog = WScript.CreateObject("Shell.Application")

    bBrowseForFolder = true

    While bBrowseForFolder
        Set objFolder = objBrowseFolderDialog.BrowseForFolder (&H0, pstrDialogLabel, BIF_editbox + BIF_returnonlyfsdirs)

        'Check that something has been returned
        If IsValidFolder(objFolder) Then
            Set objFSO = CreateObject("Scripting.FileSystemObject")

            Set objSelection = objFolder.Self
            If objFSO.FolderExists(objSelection.Path) Then
                'A valid folder has been selected
                SelectFolder = objSelection.Path
                bBrowseForFolder = false
                'The selection is not a valid folder, try again...
                MsgBox objFolder.Title & " is not a valid folder, please select another folder" _
                    , vbOKOnly & vbExclamation, "Invalid Selection"
            End If
            'Nothing was selected, so return a null string
            SelectFolder = ""
            bBrowseForFolder = false
        End If
End Function

Function IsValidFolder(pobjFolder)
    'Check that we have a valid value
    'i.e. you can concatenate it to a string
    Dim strTest

    On Error Resume Next

    strTest = " " & pobjFolder

    If Err  0 Then
        IsValidFolder = false
        IsValidFolder = true
    End If

    On Error GoTo 0
End Function
Author: Stephen Millard
Tags: | vbs |

Buy me a coffeeBuy me a coffee

Related posts that you may also like to read