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

'Defintions
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 struture
CreatestrDestinationFolder
CreateBuildFile
MakeFromBuildFile

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

'-------------
'SUB ROUTINES
'-------------

'Read the source folder structure and store it
Sub CreateBuildFile()
    objFSO.CreateTextFile(strBuildFoldersFile)
    Set objFile = objFSO.CreateTextFile(strBuildFoldersFile, True)
    ReadstrSourceFolders(strSourceFolder)
    objFile.Close
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
        objFSO.CreateFolder(strDestinationFolder)
        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
    Loop
    objFile.Close
End Sub

'Remove the file that was holiding the data structure
Sub DeleteBuildFile()
    objFSO.DeleteFile(strBuildFoldersFile)
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
        objFile.WriteLine(StripstrSourceFolder(objSubfolder.Path))
        ReadstrSourceFolders(objSubfolder.Path)
    Next
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

'----------
'FUNCTIONS
'----------
'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
            Else
                '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
        Else
            'Nothing was selected, so return a null string
            SelectFolder = ""
            bBrowseForFolder = false
        End If
    Wend
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
    Else
        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