Revit Central files to Local Files without a revit server

Right Click to create LOCAL files from CENTRAL files (not Revit Server)

The Issue:

Revit Central Files require users to create local files. Normally if you open a central file it asks if you want to create a local copy, but it doesn't replace *CENTRAL* with *LOCAL*.

First I started with a VBS that you can add to the right-click send to. This works pretty well, but I want better for my users and myself so I did a little research into registry and shell addins. Come to find out it isn't that difficult of a trick to manage.

The Solution:

I got the idea from Stack-Overflow:  Add menu item to windows context menu only for specific filetype http://stackoverflow.com/a/2124396/2027240

and A script I created and have been modifying for years...

Always back up your registry prior to any registry additions!

This is a registry entry
in the (Default) Of the Command Of the Localize Central subkey...

WScript.exe  "\\YOUR_SERVER_AD_HERE.local]\_SCRIPT\Revit\REVIT_Localize.vbs" "%1"

The Registry entry looks more like this in the .REG file:

Windows Registry Editor Version 5.00
[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Revit.Project\shell\Localize Central\Command]
@="WScript.exe  \"\\\\[YOUR_SERVER_AD_HERE.local]\\_SCRIPT\\Revit\\REVIT_Localize.vbs\" \"%1\""

 Which adds a connect to the Script:

REVIT_Localize.vbs

Located:

 [YOUR_SERVER_AD_HERE.local]\_SCRIPT\Revit\

Where [YOUR_SERVER_AD_HERE.local] is the Active Directory (AD) path back to your local content set up with your IT department or as a common location to your scripts.  

SO WHAT HAPPENS??

With this in the registry, You get a shell extension like this when you right click any .rvt file:

By right-clicking and selecting Localize Central

WScript.exe

Executes the script
REVIT_Localize.VBS 

Passes the file with the "%1"

And the Script does the rest.






An example of a script I need to clean up is below- sorry it is really messy and I need to remake it simpler- but the code to hack and slash the filename and clean it up is part of the subroutines.

The Subroutines look for job numbers and some other organizing information to create a local copy in
__[USER LOGIN NAME]\_PROJECTS\

You can sub your own script there : ) Or modify this one. I will clean this up later and repost.

REVIT_Localize.VBS:
Updated 2020-07-08:

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