SOLIDWORKS Assembly tree copied and suffix is added for each file
SOLIDWORKS Assembly tree copied and suffix is added for each file

This example demonstrates how to copy the assembly or drawing tree to a new location. Macro allows to add suffix to each file in the tree. Macro will preserve and replace all the required references on all levels of the assembly.

Specify the input file to move, destination folder and suffix in the constants at the beginning of the macro

Const FILE_PATH As String = "D:\Input\Assm1.SLDASM" 'full path to an input assembly or drawing
Const DEST_FOLDER As String = "D:\Output" 'Destination location. Do not add the backslash '\' at the end of the folder path
Const SUFFIX As String = "_CodeStack" 'Suffix to add to each file in the tree
Const FILE_PATH As String = "D:\Input\Assm1.SLDASM"
Const DEST_FOLDER As String = "D:\Output"
Const SUFFIX As String = "_CodeStack"


Dim swDmApp As SwDocumentMgr.SwDMApplication4

Sub main()

    Dim swClassFact As SwDocumentMgr.swDmClassFactory
    Set swClassFact = New SwDocumentMgr.swDmClassFactory
    Set swDmApp = swClassFact.GetApplication(LIC_KEY)
    If Not swDmApp Is Nothing Then
        Dim i As Integer
        Dim srcChildren As Variant
        Dim destChildren() As String
        Dim destFilePath As String
        destFilePath = CreateDestinationPath(FILE_PATH, DEST_FOLDER, SUFFIX)
        srcChildren = GetReferencedDocuments(FILE_PATH)
        ReDim destChildren(UBound(srcChildren))
        For i = 0 To UBound(srcChildren)
            destChildren(i) = CreateDestinationPath(CStr(srcChildren(i)), DEST_FOLDER, SUFFIX)
        Debug.Print swDmApp.CopyDocument(FILE_PATH, destFilePath, srcChildren, destChildren, swMoveCopyOptions_e.swMoveCopyOptionsOverwriteExistingDocs, CreateSearchData())
    End If
End Sub

Function CreateDestinationPath(srcPath As String, destFolder As String, suff As String)
    Dim fileName As String
    Dim ext As String
    fileName = Mid(srcPath, InStrRev(srcPath, "\"), InStrRev(srcPath, ".") - InStrRev(srcPath, "\"))
    ext = Right(srcPath, Len(srcPath) - InStrRev(srcPath, ".") + 1)
    CreateDestinationPath = destFolder & fileName & suff & ext
End Function

Function GetReferencedDocuments(filePath As String) As Variant
    Dim refDocs() As String
    Dim isInit As Boolean
    isInit = False
    Dim swDmDoc As SwDocumentMgr.SwDMDocument19
    Dim searchOpts As SwDocumentMgr.SwDMSearchOption
    Set searchOpts = CreateSearchData
    Set swDmDoc = OpenDocument(filePath)
    If Not swDmDoc Is Nothing Then
        Dim vBrokenRefs As Variant
        Dim vVirtComps As Variant
        Dim vTimeStamps As Variant
        Dim vFilePaths As Variant
        vFilePaths = swDmDoc.GetAllExternalReferences4(searchOpts, vBrokenRefs, vVirtComps, vTimeStamps)
        If Not IsEmpty(vFilePaths) Then
            Dim i As Integer
            For i = 0 To UBound(vFilePaths)
                Dim childFilePath As String
                childFilePath = vFilePaths(i)
                If Not isInit Then
                    ReDim refDocs(0)
                    refDocs(0) = childFilePath
                    isInit = True
                ElseIf Not Contains(refDocs, childFilePath) Then
                    ReDim Preserve refDocs(UBound(refDocs) + 1)
                    refDocs(UBound(refDocs)) = childFilePath
                End If
                Dim vChildRefs As Variant
                vChildRefs = GetReferencedDocuments(childFilePath)
                If Not IsEmpty(vChildRefs) Then
                    Dim j As Integer
                    For j = 0 To UBound(vChildRefs)
                        If Not Contains(refDocs, CStr(vChildRefs(j))) Then
                            ReDim Preserve refDocs(UBound(refDocs) + 1)
                            refDocs(UBound(refDocs)) = vChildRefs(j)
                        End If
                End If
            GetReferencedDocuments = Empty
            Exit Function
        End If
        err.Raise vbObjectError, "", "Failed to open document: " & filePath
    End If
    GetReferencedDocuments = refDocs
End Function

Function OpenDocument(filePath As String) As SwDocumentMgr.SwDMDocument19
    Dim err As SwDmDocumentOpenError
    Dim docType As SwDocumentMgr.SwDmDocumentType
    Dim ext As String
    ext = LCase(Right(filePath, 6))
    Select Case ext
        Case "sldprt"
            docType = swDmDocumentPart
        Case "sldasm"
            docType = swDmDocumentAssembly
        Case "slddrw"
            docType = swDmDocumentDrawing
    End Select
    Dim swDmDoc As SwDocumentMgr.SwDMDocument19
    Set swDmDoc = swDmApp.GetDocument(filePath, docType, True, err)
    Set OpenDocument = swDmDoc
End Function

Function CreateSearchData() As SwDocumentMgr.SwDMSearchOption
    Dim searchOpts As SwDocumentMgr.SwDMSearchOption
    Set searchOpts = swDmApp.GetSearchOptionObject
    searchOpts.SearchFilters = SwDmSearchFilters.SwDmSearchExternalReference + SwDmSearchFilters.SwDmSearchRootAssemblyFolder + SwDmSearchFilters.SwDmSearchSubfolders + SwDmSearchFilters.SwDmSearchInContextReference
    Set CreateSearchData = searchOpts
End Function

Function Contains(arr As Variant, item As String) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr)
        If LCase(arr(i)) = LCase(item) Then
            Contains = True
            Exit Function
        End If
    Contains = False
End Function