Macro to make independent copy of the SOLIDWORKS component and copy drawing

Edit ArticleEdit Article
More 'Goodies'

This VBA macro mimics the functionality of Make Independent feature of SOLIDWORKS, but will also additionally copy and rename the file associated with the copied part or assembly component.

Make Independent menu command
Make Independent menu command

This macro can work with a single component or multiple selected components, but all of the components must correspond to the same file.

Macro will copy the associated drawing and place it next to the target file with the same name.


  • Macro will only copy drawing which matches the name of the source file and placed in the same folder
  • Macro will not overwrite the destination drawing file if already exists

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

  lStructSize As Long
  hwndOwner As LongPtr
  hInstance As LongPtr
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As LongPtr
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    On Error GoTo catch_
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    If Not swModel Is Nothing Then
        If swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Then
            Dim swAssy As SldWorks.AssemblyDoc
            Set swAssy = swModel
            Dim vComps As Variant
            vComps = GetSelectedComponents(swModel.SelectionManager)
            If Not IsEmpty(vComps) Then
                Dim i As Integer
                Dim path As String
                path = vComps(0).GetPathName()
                For i = 1 To UBound(vComps)
                    If LCase(vComps(i).GetPathName()) <> LCase(path) Then
                        Err.Raise vbError, "", "Only identical components are supported"
                    End If
                Dim ext As String
                ext = Right(path, Len(path) - InStrRev(path, ".") + 1)
                Dim filter As String
                Dim fileType As String
                If LCase(ext) = ".sldprt" Then
                    fileType = "SOLIDWORKS Parts"
                ElseIf LCase(ext) = ".sldasm" Then
                    fileType = "SOLIDWORKS Assemblies"
                    Err.Raise vbError, "", "Unknown error"
                End If
                filter = fileType & " (*" & ext & ")|*" & ext & "|All Files (*.*)|*.*"
                Dim replaceFilePath As String
                replaceFilePath = BrowseForFileSave("Select replacement file path", filter, path)
                If replaceFilePath <> "" Then
                    If False = swAssy.MakeIndependent(replaceFilePath) Then
                        Err.Raise vbError, "", "Failed to make components independent"
                    End If
                    MakeDrawingIndependent path, replaceFilePath
                End If
                Err.Raise vbError, "", "Select components"
            End If
            Err.Raise vbError, "", "Only assembly documents are supported"
        End If
        Err.Raise vbError, "", "No model found"
    End If
    GoTo finally_
    MsgBox Err.Description, vbCritical
End Sub

Sub MakeDrawingIndependent(srcFilePath As String, destFilePath As String)
    Dim srcDrwFilePath As String
    srcDrwFilePath = Left(srcFilePath, InStrRev(srcFilePath, ".") - 1) & ".slddrw"
    Dim destDrwFilePath As String
    destDrwFilePath = Left(destFilePath, InStrRev(destFilePath, ".") - 1) & ".slddrw"

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FileExists(srcDrwFilePath) Then
        If fso.FileExists(destDrwFilePath) Then
            Err.Raise vbError, "", "Destination drawing already exists"
        End If
        fso.CopyFile srcDrwFilePath, destDrwFilePath, False
        Dim destDrwFilePathAttr As VbFileAttribute
        destDrwFilePathAttr = GetAttr(destDrwFilePath)
        If destDrwFilePathAttr And vbReadOnly Then
            Debug.Print "Removing the read-only flag from the destination drawing: " & destDrwFilePath
            SetAttr destDrwFilePath, destDrwFilePathAttr Xor vbReadOnly
        End If
        If False = swApp.ReplaceReferencedDocument(destDrwFilePath, srcFilePath, destFilePath) Then
            Err.Raise vbError, "", "Failed to replace referenced drawing document"
        End If
    End If
End Sub

Function GetSelectedComponents(selMgr As SldWorks.SelectionMgr) As Variant

    Dim isInit As Boolean
    isInit = False
    Dim swComps() As SldWorks.Component2

    Dim i As Integer
    For i = 1 To selMgr.GetSelectedObjectCount2(-1)
        Dim swComp As SldWorks.Component2
        Set swComp = selMgr.GetSelectedObjectsComponent4(i, -1)
        If Not swComp Is Nothing Then
            If Not isInit Then
                ReDim swComps(0)
                Set swComps(0) = swComp
                isInit = True
                If Not Contains(swComps, swComp) Then
                    ReDim Preserve swComps(UBound(swComps) + 1)
                    Set swComps(UBound(swComps)) = swComp
                End If
            End If
        End If

    If isInit Then
        GetSelectedComponents = swComps
        GetSelectedComponents = Empty
    End If

End Function

Function BrowseForFileSave(title As String, filters As String, initFilePath As String) As String
    Const FILE_PATH_BUFFER_SIZE As Integer = 260
    Dim initFileName As String
    initFileName = Right(initFilePath, Len(initFilePath) - InStrRev(initFilePath, "\"))
    ofn.lpstrFilter = Replace(filters, "|", Chr(0)) & Chr(0)
    ofn.lpstrTitle = title
    ofn.nMaxFile = FILE_PATH_BUFFER_SIZE
    ofn.nMaxFileTitle = FILE_PATH_BUFFER_SIZE
    ofn.lpstrInitialDir = Left(initFilePath, InStrRev(initFilePath, "\") - 1)
    ofn.lpstrFile = initFileName & String(FILE_PATH_BUFFER_SIZE - Len(initFileName), Chr(0))
    ofn.lStructSize = LenB(ofn)
    Dim res As Boolean
    res = GetSaveFileName(ofn)

    If res Then
        Dim filePath As String
        filePath = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, vbNullChar) - 1)
        Dim vFilters As Variant
        vFilters = Split(filters, "|")
        Dim ext As String
        ext = vFilters((ofn.nFilterIndex - 1) * 2 + 1)
        ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
        If LCase(Right(filePath, Len(ext))) <> LCase(ext) Then
            filePath = filePath & ext
        End If
        BrowseForFileSave = filePath
        BrowseForFileSave = ""
    End If
End Function

Function Contains(vArr As Variant, item As Object) As Boolean
    Dim i As Integer
    For i = 0 To UBound(vArr)
        If vArr(i) Is item Then
            Contains = True
            Exit Function
        End If
    Contains = False
End Function

Product of Xarial Product of Xarial