(INSTALLER VBS)REVIT Recreate local file in one click

I have an An example of a script available that I generated to copy REVIT central files to local files in a standardized local directory system, delete existing file & backup folder and rename from central to local.

You can use it as a starting point for your localizers.

Revit VBS to Localize files:

• Unzip the zip file to your desktop
• Double click the install
• It copies the other VBS to your SendTo folder

To use-

This will require some modifications for your specific needs but this one:

• Save the script in black below to FILE-REVIT_Localize.vbs 
•  Double click it and it should auto-copy itself to the sendto folder.
•  Then select any *CENTRAL*.RVT file on the file server and it will make a copy to the MyDocuments\[jobno]\*LOCAL*.RVT file
•  This will ask to use a a local copy on open in Revit

• This will need some tweaking with the Regular Expression to match your job numbers
• It requires the word *CENTRAL* in the Central file name to replace with LOCAL in the local filename 

• It looks for project numbers that match a Regular Expression generated to match a specific sequence- Refined by reading through some Microsoft Regex Info and tested here. (don't forget Regex101.com for the best regex checker on the planet!) 
• Creates a folder structure in MyDocs "_Projects\[job-id]".
• It deletes any existing local copy and backup folder at this location.
• Copies the files and renames them.
• It pops up with the message screen showing how many files it was sent.
• This could probably be incorporated into a BAT file if you wanted it to automatically recreate local files at startup or on demand... etc...

Use carefully and enjoy!

Ron E. Allen

UPDATE: All in one file to copy itself to sendto or accept files to localize:

Watch for wraps! Debug in excel VBA.

VBS: 

Option Explicit Const ThisScriptVersion = "2020-07-08.01.5" ''Revisions ''2010-01-21-Central to local - added delimeters for CENTRAL and LOCAL ''2010-01-21-defined basic arguments for drag&Drop ''2020-07-08-Combined drag and drop and sendto install functionality in core program ''Define constants ''CENTRAL TO LOCAL DELIMETERS Public Const StrFileLocalDelim = "LOCAL" ''delimiater to use for local filename- if other desired see CentralToLocal() function Public Const StrFileCentralDelim = "CENTRAL" ''Delimiter in source filename to be replaces - MUST exist! Public strMsg ''sum of messages at end Main ''Call the MAIN subroutine ''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ''''BEGIN SCRIPT<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Sub Main() ''Main Subroutine Dim ArgItem ''Arg Item in wscript Dim DirCt ''Count Directories in drag and drop Dim FileCt ''Count Files in drag and drop Dim InstrPos ''Position locator for "CENTRAL" Dim DestFullName ''Destination Filename & PATH Dim DestPath ''Destination Path Dim LocalPrefix ''Local Prefix Path for project files Dim x ''For split Dim I, j ''generic counter Dim JobNo ''For Job Number string Dim DestFullPath ''Destination full path + filename ''objFSO=object FileSystemObject - WARNING anything FSO is LIVE on the file/folder realtime, not scripttime, take extreme care! Dim ObjFSO ''As New FileSystemObject ''objfso Dim WSOS ''Winscript object to gest special folders Set WSOS = Wscript.CreateObject("Wscript.Shell") ''Use WSH to get special SENDTO folder Set ObjFSO = CreateObject("Scripting.FileSystemObject") ''get File system object ''CHECK ARGS- IF USER DOUBLE CLICKED OR NO ARGS RETURN INSTRUCTIONS & offer to install to sendto If Wscript.Arguments.Count = 0 Then ''double clicked- no arguments - sent to install / inform InstallToSendto ''Install and general info Else For Each ArgItem In Wscript.Arguments ''Cycle through args in wscript If ObjFSO.FileExists(ArgItem) Then FileCt = FileCt + 1 ''Add one to file count If ObjFSO.FolderExists(ArgItem) Then DirCt = DirCt + 1 ''Add one to folder count Next If DirCt + FileCt <> Wscript.Arguments.Count Then ''nothing to do! MsgBox "File Or Directory Does Not Exist", vbOK, "Source File or Folder error" ''error message EXIT_CLEANUP ''Force exit End If End If ''Parse through arguments - find '*CENTRAL*.RVT' references For j = 0 To Wscript.Arguments.Count - 1 ''For Each ArgItem In WSCRIPT.Arguments ArgItem = Wscript.Arguments(j) ''Get next argument from wscript '''ArgItem = "K:\Denver\Projects\2020\200431 Solana Beeler Park Wrap\CDs\Revit\200431 - Solana Beeler Park Wrap_R19.rvt" '''< ''''''''''''' ''Sets the folder as a prefix for the file name, If preferred ''relocate to a hard path like "C:\Projects\" ''- make sure Read-Write as available at location specified. LocalPrefix = WSOS.SpecialFolders("MyDocuments") & "\_Projects\" ''<< '' LocalPrefix ="C:\_REVIT-Projects\" ''example of C: location- uncomment to use ''If "CENTRAl" in filename, and RIGHT filename = .rvt and File exists then If InStr(1, Trim(ArgItem), StrFileCentralDelim, 1) > 0 _ And UCase(Right(ArgItem, 4)) = ".RVT" _ And ObjFSO.FileExists(ArgItem) _ Then DestFullName = LocalPrefix ''Set local prefix as base path JobNo = "" ''set to nothing JobNo = GetJobNo(ArgItem, True) ''Regex against /whole path/ to extract something like a job ID for sub folder If JobNo > "" Then ''If Job No returns a hit DestPath = LocalPrefix & JobNo & "\" ''Add it to the destination path to sort by jobno folder End If ''jobno ''MsgBox ArgItem & vbCr & " TO " & vbCr & DestPath, , "debug" ''debug msgbox - commented out CopyFile ArgItem, DestPath ''copy old fp & Name to new fp & name End If ''file exists... Next ''j to grab next wscript argument. ''Do Cleanup EXIT_CLEANUP End Sub ''main Sub EXIT_CLEANUP() ''exit script messages and cleanups if necessary ''add any messages here MsgBox strMsg, vbInformation + vbOKOnly, "Completed:" ''inform Wscript.quit ''exit script End Sub Sub InstallToSendto() ''Function to copy this script to sendto folder Dim strThisScript ''String to hold this folder path & Name Dim WSOS ''Winscript object to gest special folders Dim strSendToFP ''SendTo File path Dim ObjFSO ''As FileSystemObject Set ObjFSO = CreateObject("Scripting.FileSystemObject") ''create objFSO strThisScript = Wscript.ScriptFullName ''this script fill anme and path Set WSOS = Wscript.CreateObject("Wscript.Shell") ''Use WSH to get special SENDTO folder strSendToFP = WSOS.SpecialFolders("SendTo") & "\" ''Get SENDTO path Set WSOS = Nothing ''destroy reference - no longer needed ''Message informing user - note [space]_ is a continute to next line for readability... If MsgBox("This Script version:" & ThisScriptVersion & vbCr & vbCr _ & "Click YES to install: " & vbCr _ & Replace(strThisScript, "\", "\ ") & vbCr & vbCr _ & "to SEND TO folder: " & vbCr _ & Replace(strSendToFP, "\", "\ "), _ vbYesNo, "Install the localizer to your sendto folder?") <> vbYes _ Then MsgBox "Nothing done.", vbOKOnly, "Exiting" ''Inform Else ''try to copy this file to sendto If CopyFile(strThisScript, strSendToFP) = False Then MsgBox "Error copying file.", vbCritical + vbOKOnly, "Warning" Else MsgBox "Success installing to SendTo", vbInformation + vbOKOnly, "Success!" ''inform End If End If ''msg box for copy ''Message informing use MsgBox "Once installed to the SENDTO folder, " & vbCr & vbCr _ & "Right-Click any *CENTRAL*.RVT central file and >SendTo>" _ & Wscript.ScriptName & " to make a copy of the central file to the local folder and rename it." & vbCr & vbCr _ & "Drag and drop on top of the script, or a shortcut to the script also works.", _ vbInformation + vbOKOnly, "NOTE:" Wscript.quit ''force break out of script End Sub ''main ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''fileCopy Function CopyFile(Source, DestinationFp) Dim ObjFSO ''As FileSystemObject Dim objFile ''As File object Dim NewFile ''As File object Dim destfp ''destination filepath Dim newFN, newFP ''new filename and new filepath Dim RevitBackupFolder ''Revit backup folder name Set ObjFSO = CreateObject("Scripting.FileSystemObject") ''create objFSO If ObjFSO.FileExists(Source) Then ''Check if file exists Set objFile = ObjFSO.GetFile(Source) ''Get source file FolderCheck DestinationFp 'check and set destination objFile.Copy DestinationFp, True ''copy and overwrite Set NewFile = ObjFSO.GetFile(DestinationFp & objFile.Name) ''get new file w/old name! ''copy check if not rvt file then don't modify copied file name If LCase(Right(NewFile.Name, 4)) <> ".rvt" Then CopyFile = ObjFSO.FileExists(DestinationFp & objFile.Name) strMsg = strMsg & "Copied/localized:" & vbCr & objFile.Name & vbCr ''add to inform message Exit Function ''skip central to local for vbs copy End If ''Otherwise rename copy of file to "LOCAL" newFP = NewFile.ParentFolder.Path & "\" newFN = CentralToLocalRegExp(NewFile.Name) newFN = GetJobNo(newFN, False) If ObjFSO.FileExists(newFP & newFN) Then ''Check if FP & FN exist ObjFSO.DeleteFile newFP & newFN, True ''delete FN at FP if exists End If NewFile.Name = newFN ''replace "Central" with "LOCAL" in filename ''Check for backup folder''''''''''''''''''''''''''''''''''''' RevitBackupFolder = _ (left(NewFile.Path, Len(NewFile.Path) - 4)) & "_backup" If ObjFSO.FolderExists(RevitBackupFolder) Then ''If backup exists ObjFSO.DeleteFolder RevitBackupFolder ''delete old backup folder End If ''end if If ObjFSO.FileExists(NewFile.Path) Then strMsg = strMsg & "Copied/localized:" & vbCr & newFP & newFN & vbCr Else strMsg = strMsg & "**ERROR**copying:" & vbCr & newFP & newFN & vbCr End If End If End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''create new folder Recursively Function FolderCheck(FolderPath) ''as folder Dim ObjFSO ''As FileSystemObject Dim x, fp, I ''X for split and FP for filepath, I as counter Set ObjFSO = CreateObject("Scripting.FileSystemObject") ''Create FSO If ObjFSO.FolderExists(FolderPath) Then ''Folder Exists Set FolderCheck = ObjFSO.GetFolder(FolderPath) ''- return folder Exit Function Else ''folder didn't exist x = Split(FolderPath, "\") fp = "" For I = 0 To UBound(x) fp = fp & x(I) & "\" If ObjFSO.FolderExists(fp) Then Else Set FolderCheck = ObjFSO.CreateFolder(fp) ''set CreateNewFolder to last created folder End If Next ''I End If ''folder exists End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''Get user login ID Function GetUserLoginID() Dim WSHNetwork Set WSHNetwork = CreateObject("WScript.Network") GetUserLoginID = CStr(WSHNetwork.UserName) End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''' ''Return cleaned up job ID with RegExp Function GetJobNo(ByVal PathStr, StripExtension) ''file ane aor file path and return w/o extension Dim Match ''imitial match object Dim Matches ''for regex matches in match Dim objRegex ''As New REGEXP ''for regex object Dim Extension ''file extension Extension = LCase(Right(PathStr, 4)) ''extension check to not remove "." If Extension = ".rvt" _ Or Extension = ".vbs" Then ''if it is a RVT or VBS PathStr = left(PathStr, Len(PathStr) - 4) ''truncate the extension off the filename Else Extension = "" ''null the extenson End If Set objRegex = CreateObject("vbscript.REGEXP") ''new Regular Expression object objRegex.Pattern = "(\d{6}[^\\]{0,})" ''see regex101.com for more about regular expressions objRegex.IgnoreCase = True ''Ignore CaSe objRegex.MultiLine = True ''Single line only - ignore everything after [return] if exists Set Matches = objRegex.Execute(PathStr) ''Run the check to fins matches On Error Resume Next ''if it bombs out continue on Set Match = Matches(0) ''use match 0 fr this case GetJobNo = Match.Value ''return the value of the match (if any - if not returns nothing) On Error GoTo 0 ''Regular error matching - stops program If Match > "" Then ''If match isn't balnk objRegex.Global = True ''Global string regex search objRegex.Pattern = "[^a-zA-Z0-9!@#$%^&*:()_\.]{1,}" ''Match any non-standard caharacter GetJobNo = objRegex.Replace(GetJobNo, "-") ''replace one or more junk chars with a dash objRegex.Pattern = "[\.]{1,}" ''Match one or more "." GetJobNo = objRegex.Replace(GetJobNo, "_") ''Replace one or more remaining dots with an underscore End If If Not StripExtension Then GetJobNo = GetJobNo & Extension ''append extension if set ''returns "" if no match End Function '''''''''''''''''''''''''''''''' ''Function central to local Regexp Function CentralToLocalRegExp(FName) ''regular Expressions to replace values Dim re ''As New REGEXP Set re = New REGEXP ''Regular expressions object see regex101.com for details re.Pattern = "(" & StrFileCentralDelim & ")" ''Constant for central pattern match re.IgnoreCase = True ''ignore CaSe re.Global = True ''Global search in string ''Run Repace and pass value back: CentralToLocalRegExp = re.Replace(FName, StrFileLocalDelim) End Function