(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:
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
Comments
Post a Comment