Macro to copy file paths to all drawings of an assembly components using SOLIDWORKS API

This VBA macro finds all the drawings which were created for all components of the active assembly using SOLIDWORKS API and puts the paths to the clipboard.

SOLIDWORKS provides the functionality to open the drawings of the component:

This feature allows to find drawings one-by-one, but sometimes it is required to quickly find all drawings used by components of this assembly. This can be a part of automation software. This macro will traverse all the references and find all drawings paths. Once completed the confirmation message below is displayed.

The content of the clipboard can be pasted into any text or table editor, like Notepad or Excel (use ctrl+V shortcut or Paste command).

Notes

• Suppressed components are excluded from the search
• Drawings are searched in the same folder as the input assembly (including sub folders)
• Drawings are searched by reference, rather than by name, so drawing can have any name
• Drawing paths are separated with a new line symbol

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
try:
    
    On Error GoTo catch
    
    Set swModel = swApp.ActiveDoc
    
    If Not swModel Is Nothing Then
        
        If swModel.GetPathName() = "" Then
            Err.Raise vbError, "", "File is not saved"
        End If
        
        Dim vDrawingPaths As Variant
        
        Dim dir As String
        dir = swModel.GetPathName()
        dir = Left(dir, InStrRev(dir, "\"))
        
        If TypeOf swModel Is SldWorks.AssemblyDoc Then
            Dim swAssy As SldWorks.AssemblyDoc
            Set swAssy = swModel
            Dim vRefs As Variant
            vRefs = GetAllReferences(swAssy)
            vDrawingPaths = GetDrawingsForFiles(vRefs, dir)
        ElseIf TypeOf swModel Is SldWorks.PartDoc Then
            vDrawingPaths = GetDrawingsForFiles(Array(swModel.GetPathName()), dir)
        Else
            Err.Raise vbError, "", "Only part or assemblies are supported"
        End If
            
        AddPathsToClipboard vDrawingPaths
        
        swApp.SendMsgToUser2 "Drawing paths are copied to clipboard", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
        
    Else
        Err.Raise vbError, "", "Please open part or assembly"
    End If
    
    GoTo finally
    
catch:
    Debug.Print Err.Number
    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
    
finally:
    
End Sub

Function GetAllReferences(assy As SldWorks.AssemblyDoc) As Variant
    
    Dim refs() As String
    Dim isInit As Boolean
    isInit = False
    
    Dim vComps As Variant
    vComps = assy.GetComponents(False)
    
    Dim i As Integer
    
    For i = 0 To UBound(vComps)
        
        Dim swComp As SldWorks.Component2
        
        Set swComp = vComps(i)
        
        Dim path As String
        path = swComp.GetPathName()
        
        If Not swComp.IsSuppressed() Then
            If Not isInit Then
                isInit = True
                ReDim refs(0)
                refs(0) = path
            Else
                If Not ContainsFilePath(refs, path) Then
                    ReDim Preserve refs(UBound(refs) + 1)
                    refs(UBound(refs)) = path
                End If
            End If
        End If
        
    Next
    
    GetAllReferences = refs
    
End Function

Function GetDrawingsForFiles(files As Variant, path As String) As Variant
    
    Dim drawingPaths() As String
    Dim isInit As Variant
    isInit = False
    
    Dim vAllDrawings As Variant
    vAllDrawings = FindAllDrawings(path)
        
    If Not IsEmpty(vAllDrawings) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vAllDrawings)
            
            Dim drawPath As String
            drawPath = vAllDrawings(i)
            
            Dim vDeps As Variant
            
            vDeps = swApp.GetDocumentDependencies2(drawPath, True, True, False)
            Dim j As Integer
            
            If Not IsEmpty(vDeps) Then
            
                For j = 1 To UBound(vDeps) Step 2
                    If ContainsFilePath(files, CStr(vDeps(j))) Then
                        If Not isInit Then
                            isInit = True
                            ReDim drawingPaths(0)
                        Else
                            ReDim Preserve drawingPaths(UBound(drawingPaths) + 1)
                        End If
                        drawingPaths(UBound(drawingPaths)) = drawPath
                        Exit For
                    End If
                Next
                
            End If
            
        Next
        
    End If
    
    GetDrawingsForFiles = drawingPaths
    
End Function

Function FindAllDrawings(path As String) As Variant
    
    Const DRAW_EXTENSION As String = "slddrw"
    FindAllDrawings = GetFiles(path, True, DRAW_EXTENSION)
    
End Function

Function GetFiles(path As String, Optional includeSubFolders As Boolean = True, Optional ext As String = "") As Variant

    Dim paths() As String
    Dim isInit As Boolean
    
    isInit = False
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim folder As Object
    Set folder = fso.GetFolder(path)
    
    CollectFilesFromFolder folder, includeSubFolders, ext, paths, isInit
    
    If isInit Then
        GetFiles = paths
    Else
        GetFiles = Empty
    End If
    
End Function

Sub CollectFilesFromFolder(folder As Object, includeSubFolders As Boolean, ext As String, ByRef paths() As String, ByRef isInit As Boolean)
    
    For Each file In folder.files
        Dim fileExt As String
        fileExt = Right(file.path, Len(file.path) - InStrRev(file.path, "."))
        If LCase(fileExt) = LCase(ext) Then
            If Not isInit Then
                ReDim paths(0)
                isInit = True
            Else
                ReDim Preserve paths(UBound(paths) + 1)
            End If
            paths(UBound(paths)) = file.path
        End If
    Next
    
    If includeSubFolders Then
        Dim subFolder As Object
        For Each subFolder In folder.SubFolders
            CollectFilesFromFolder subFolder, includeSubFolders, ext, paths, isInit
        Next
    End If
    
End Sub

Sub AddPathsToClipboard(vPaths As Variant)

    Dim text As String
    Dim i As Integer
    
    For i = 0 To UBound(vPaths)
        If i <> 0 Then
            text = text & vbCrLf
        End If
        text = text & CStr(vPaths(i))
    Next

    Dim dataObject As Object
    Set dataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    dataObject.SetText text
    dataObject.PutInClipboard
    Set dataObject = Nothing
    
End Sub

Function ContainsFilePath(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
            ContainsFilePath = True
            Exit Function
        End If
    Next
    
    Contains = False
    
End Function