Dynamically create folder structure on UNC share

[jonmc99]

Hi Everyone,

I am using some code kindly provided by snotmore...

Call subCreateFolders("C:\test1\test2\test3\")


Sub subCreateFolders(strPath)
   Dim objFileSys
   Dim strPath, strNewFolder
    
   Set objFileSys = CreateObject("Scripting.FileSystemObject")

   If Right(strPath, 1) <> "\" Then
      strPath = strPath & "\"
   End If

   strNewFolder = ""
   Do Until strPath = strNewFolder
      strNewFolder = Left(strPath, InStr(Len(strNewFolder) + 1, strPath, "\"))
    
      If objFileSys.FolderExists(strNewFolder) = False Then
         objFileSys.CreateFolder(strNewFolder)
      End If
   Loop
End Sub

Is there a way to make the above work with a UNC?

I love the way the code dynamically creates the folders if they don't exist and is exactly what I need but it needs to work over the network to a UNC share. I think the \\ at the beginning of a UNC is what's causing this to not work.

Any ideas?

To give a little background, I'm backing up a file located on an RDSH server that resides in the %localappdata% folder. I'm saving this to a specific folder on the network based on the users login name. When the user logs in again, another script using slightly different source and destination folders will copy the data back. Therefore, on the restore, the above works great... just the backup that fails.

 

[jonmc99]

If anyone is interested, below is the complete code I'm using...

Option Explicit
On Error Resume Next

' Logoff Script to Copy Files from local hard drive to Network
'==========================================================================


' Read LDAP(Active Directory) information to assign the user's info to variables.
'==========================================================================
Dim qQuery, objSysInfo, objuser, LogonID
Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.Username
Set objuser = GetObject(qQuery)
LogonID = objUser.sAMAccountName

' Perform Copy Command
'==========================================================================
dim filesys, objShell, UserDataLocalPath, CopySource, CopyDest, NetworkLocalAppData
Set objShell = CreateObject("WScript.Shell")

NetworkLocalAppData = "\\server\userprofiles\" & LogonID & ".V2\LocalAppData"
UserDataLocalPath = ObjShell.ExpandEnvironmentStrings("%localappdata%")
CopySource = UserDataLocalPath & "\Folder1\Folder2"
CopyDest = NetworkLocalAppData & "\Folder1\Folder2"

set filesys=CreateObject("Scripting.FileSystemObject") 
If (filesys.FolderExists(CopySource)) Then 
	If Not (filesys.FolderExists(CopyDest)) Then 
		Call subCreateFolders(CopyDest & "\")
	End If
filesys.CopyFolder CopySource , CopyDest , True
Else
End If


Sub subCreateFolders(strPath)
   Dim objFileSys
   Dim strNewFolder
    
   Set objFileSys = CreateObject("Scripting.FileSystemObject")

   If Right(strPath, 1) <> "\" Then
      strPath = strPath & "\"
   End If

   strNewFolder = ""
   Do Until strPath = strNewFolder
      strNewFolder = Left(strPath, InStr(Len(strNewFolder) + 1, strPath, "\"))
    
      If objFileSys.FolderExists(strNewFolder) = False Then
         objFileSys.CreateFolder(strNewFolder)
      End If
   Loop
End Sub

The above is to backup and to restore you have another vb of the above and swap the CopySource & CopyDest around.

Works well but just need to sort the UNC bit if anyone can help?

 

[guitarzan]

See if this helps:

http://www.robvanderwoude.com/vbstech_folders_md.php

 

[jonmc99]

Thanks guitarzan, that was exactly what I needed and works perfectly.

However, I've come across another issue which I hope you can help me with.

I've discovered that although the code below works well at backing up and restoring the data with overwrites, it doesn't work well when file names are changed in the source as it leaves copied files in the destination from a previous backup. Eventually, the backup folder will continue to get larger and the files will keep being restored.

I think a better way would be to delete the folder before backup but only if the folder exists first and only if the process is about to backup to that location. My issue is I cannot get the

filesys.DeleteFolder(CopyDest)

code in the right place that provides a consistent experience.

Any help is greatly appreciated.

My complete code:

Option Explicit
On Error Resume Next

' Logoff Script to Copy Files from local hard drive to Network
'==========================================================================


' Read LDAP(Active Directory) information to assign the user's info to variables.
'==========================================================================
Dim qQuery, objSysInfo, objuser, LogonID
Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.Username
Set objuser = GetObject(qQuery)
LogonID = objUser.sAMAccountName

' Perform Copy Command
'==========================================================================
dim filesys, objShell, UserDataLocalPath, CopySource, CopyDest, NetworkLocalAppData
Set objShell = CreateObject("WScript.Shell")

NetworkLocalAppData = "\\server\profiles\" & LogonID & ".V2\LocalAppData"
UserDataLocalPath = ObjShell.ExpandEnvironmentStrings("%localappdata%")
CopySource = UserDataLocalPath & "\Sage\Sage Report Designer 2007"
CopyDest = NetworkLocalAppData & "\Sage\Sage Report Designer 2007"

set filesys=CreateObject("Scripting.FileSystemObject") 
If (filesys.FolderExists(CopySource)) Then 
	If Not (filesys.FolderExists(CopyDest)) Then 
		Call CreateDirs(CopyDest & "\")
	End If
filesys.CopyFolder CopySource , CopyDest , True
Else
End If


Sub CreateDirs( MyDirName )
' This subroutine creates multiple folders like CMD.EXE's internal MD command.
' By default VBScript can only create one level of folders at a time (blows
' up otherwise!).
'
' Argument:
' MyDirName   [string]   folder(s) to be created, single or
'                        multi level, absolute or relative,
'                        "d:\folder\subfolder" format or UNC
'
' Written by Todd Reeves
' Modified by Rob van der Woude
' [URL unfurl="true"]http://www.robvanderwoude.com[/URL]

    Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild

    ' Create a file system object
    Set objFSO = CreateObject( "Scripting.FileSystemObject" )

    ' Convert relative to absolute path
    strDir = objFSO.GetAbsolutePathName( MyDirName )

    ' Split a multi level path in its "components"
    arrDirs = Split( strDir, "\" )

    ' Check if the absolute path is UNC or not
    If Left( strDir, 2 ) = "\\" Then
        strDirBuild = "\\" & arrDirs(2) & "\" & arrDirs(3) & "\"
        idxFirst    = 4
    Else
        strDirBuild = arrDirs(0) & "\"
        idxFirst    = 1
    End If

    ' Check each (sub)folder and create it if it doesn't exist
    For i = idxFirst to Ubound( arrDirs )
        strDirBuild = objFSO.BuildPath( strDirBuild, arrDirs(i) )
        If Not objFSO.FolderExists( strDirBuild ) Then 
            objFSO.CreateFolder strDirBuild
        End if
    Next

    ' Release the file system object
    Set objFSO= Nothing
End Sub

 

[guitarzan]

Instead of doing this in vbscript, I would strongly consider using RoboCopy instead. It's built into Vista and higher. Look into the "mir" (mirror) switch, which I think will do exactly what you want.

http://en.wikipedia.org/wiki/Robocopy

 

[jonmc99]

Thanks Guitarzan, I was clearly complicating things!!

My new single line of code for logoff is:

robocopy "%localappdata%\Sage\Sage Report Designer 2007" "\\server\profiles\%username%.V2\localappdata\Sage\Sage Report Designer 2007" /MIR /njh /njs /ndl /nc /ns /np /nfl

and to logon:

robocopy "\\server\profiles\%username%.V2\localappdata\Sage\Sage Report Designer 2007" "%localappdata%\Sage\Sage Report Designer 2007" /MIR /njh /njs /ndl /nc /ns /np /nfl

far far far more simpler... nice

p.s. It would be nice to not show a command prompt during the process but since it's so quick, it's by no means a deal breaker.