VBA macro to replace and reload active SOLIDWORKS document

This VBA macro replaces the file of the active SOLIDWORKS document and reloads it in the current session without closing the file.

This macro can be useful in demo purposes where it is required to show the model changes instantly

Macro composes the replacement file name based on the value of REPLACEMENT_SUFFIX, REPLACEMENT_PREFIX and REPLACEMENT_FILE_NAME constants

If REPLACEMENT_FILE_NAME constant is specified the REPLACEMENT_SUFFIX, REPLACEMENT_PREFIX are ignored. This can be either a relative file name or an absolute path to the replacement file.

If REPLACEMENT_FILE_NAME is empty replacement file name is composed by concatenating the valules of REPLACEMENT_SUFFIX and REPLACEMENT_PREFIX with the source file name

This macro supports Macro+ and the REPLACEMENT_FILE_NAME can be passed as the first argument.

Const REPLACEMENT_SUFFIX As String = "_replacement" 'suffix of the replacement file
Const REPLACEMENT_PREFIX As String = "_" 'prefix of the replacement file
Const REPLACEMENT_FILE_NAME As String = "replacement_Part1.sldprt" 'file name of the replacement file

#If VBA7 Then
     Private Declare PtrSafe Function PathIsRelative Lib "shlwapi" Alias "PathIsRelativeA" (ByVal path As String) As Boolean
#Else
     Private Declare Function PathIsRelative Lib "shlwapi" Alias "PathIsRelativeA" (ByVal Path As String) As boolean
#End If

Const REPLACEMENT_SUFFIX As String = ""
Const REPLACEMENT_PREFIX As String = "_"
Const REPLACEMENT_FILE_NAME As String = ""

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
    Set swModel = swApp.ActiveDoc
    
    If Not swModel Is Nothing Then
        
        Dim srcFilePath As String
    
        srcFilePath = swModel.GetPathName()
        
        Dim replFilePath As String
        
        replFilePath = GetReplacementFilePath(srcFilePath)
    
        If Dir(replFilePath, vbNormal + vbReadOnly + vbHidden) <> "" Then
            
            If TypeOf swModel Is SldWorks.DrawingDoc Then
                Err.Raise vbError, "", "Not supported"
            Else
                Const S_OK As Integer = 1
                
                If swModel.ForceReleaseLocks() = S_OK Then
                    
                    FileCopy replFilePath, srcFilePath
                    
                    Dim res As Integer
                    res = swModel.ReloadOrReplace(False, "", True)
                    
                    If res <> swComponentReloadError_e.swReloadOkay Then
                        Err.Raise vbError, "", "Failed to reload model: " & res
                    End If
                    
                Else
                    Err.Raise vbError, "", "Failed to release file"
                End If
                
            End If
            
        Else
            Err.Raise vbError, "", "Replacement file path does not exist"
        End If
        
    Else
        Err.Raise vbError, "", "Open model"
    End If
    
End Sub

Function GetReplacementFilePath(srcFilePath As String) As String
    
    If srcFilePath <> "" Then
    
        Dim fileName As String
        
        If Not TryGetReplacementFileNameFromArguments(fileName) Then
            fileName = REPLACEMENT_FILE_NAME
        End If
        
        If fileName = "" Then
            fileName = REPLACEMENT_PREFIX & GetFileNameWithoutExtension(srcFilePath) & REPLACEMENT_SUFFIX & "." & GetExtension(srcFilePath)
        End If
        
        Dim filePath As String
        
        If PathIsRelative(fileName) Then
            filePath = GetFolderName(srcFilePath) & "\" & fileName
        Else
            filePath = fileName
        End If
        
        If LCase(filePath) <> LCase(srcFilePath) Then
            GetReplacementFilePath = filePath
        Else
            Err.Raise vbError, "", "Replacement file path and source file path match"
        End If
        
    Else
        Err.Raise vbError, "", "Model is not saved on disc"
    End If
    
End Function

Function TryGetReplacementFileNameFromArguments(ByRef fileName As String) As Boolean

try_:

    On Error GoTo catch_

    Dim macroOprMgr As Object
    Set macroOprMgr = CreateObject("CadPlus.MacroOperationManager")
        
    Set macroOper = macroOprMgr.PopOperation(swApp)
    
    Dim vArgs As Variant
    vArgs = macroOper.Arguments
   
    Dim macroArg As Object
    Set macroArg = vArgs(0)
    
    fileName = CStr(macroArg.GetValue())
    TryGetReplacementFileNameFromArguments = True
    GoTo finally_
    
catch_:
    TryGetReplacementFileNameFromArguments = False
finally_:

End Function

Function GetFolderName(filePath As String) As String
    GetFolderName = Left(filePath, InStrRev(filePath, "\") - 1)
End Function

Function GetFileNameWithoutExtension(filePath As String) As String
    GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
End Function

Function GetExtension(path As String) As String
    GetExtension = Right(path, Len(path) - InStrRev(path, "."))
End Function