VBS - Duplicate Folder Structure

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 structure
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 holding 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

Buy me a coffee

Related posts that you may also like to read

• 

  VBScript: Flip Line Endings

  28 Jun 2015

  Recently I was working for a client who had particularly strict controls around access and tools that I could use. Whilst the bulk of the work I was carrying out on their Linux box could be managed using vi, I found it a little limiting when analysing some of the log files the work was producing. On the Windows machine I was using to access the files I only had Windows notepad and this really doesn’t handle Linux file endings well. As a result I put together a quick VBScript to help with this.

  Read More
• 

  A Self Installing VBScript

  28 Feb 2014

  Over the years I’ve been doing technical support I’ve had quite a few useful VBS scripts that I’d copy over to a user’s machine. Then if it necessary, they could be run again at a later date (by remote control or referring the user to it’s location and get them to run it). However I quickly tired of manually doing this and dealing with the instances where I’d accidentally copied the script to the user’s desktop instead of the location I’d really wanted. As a result I created some extra lines to add into these scripts that would install the script to the desired location and then run it from there. This meant I could run it from a flash or network drive and it would automatically go to the right place - even updating older scripts.

  Read More
• 

  Random Files Generator

  26 Aug 2013

  Whilst doing some house keeping on some old VBScript files the other day I came across one for creating test files. I’ve blogged previously about creating test files using my MTF utility and whilst it or fsutil can be very useful, this script filled a particular niche. It was created as part of a test suite of scripts it creates multiple files of a specific size filled with random printable content.

  Read More
• 

  VBScript to Convert Microsoft Office Files (Word, Excel, PowerPoint) to PDF

  20 Dec 2012

  I spend a lot of my time working with Word documents and Excel spreadsheets - it’s in the nature of what I do. I frequently found that I need to create PDF copies of these files (to send out to clients) and eventually I grew tired of having to open the files one by one and select to save each as a PDF. As a result I created a bit of VBScript to automatically convert files for me (in Windows).

  Read More