CAD Forum

Code: Select all

' ###################################################
' # Title: Open Drawing From BOM                    #
' # Version: 21.9.6                                 #
' # Author: Stefan Sterk                            #
' # Company: Idee Techniek Engineering B.V.         #
' #                                                 #
' # This macro will try to open the drawing for the #
' # selected component(s) in the Bill of Meterials. #
' #                                                 #
' # NOTE: Drawing file must be in same folder as    #
' # component and must have the same filename       #
' ###################################################

Option Explicit

Dim swApp As SldWorks.SldWorks

Sub main()

    Dim swModel  As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swTblAnn As SldWorks.TableAnnotation
    Dim swBOMTbl As SldWorks.BomTableAnnotation
    Dim swComp   As SldWorks.Component2

    Dim i As Integer, selType  As Integer
    Dim frtRow As Long, lstRow As Long
    Dim frtCol As Long, lstCol As Long
    Dim Row As Integer

    Dim vComps   As Variant
    Dim CfgName  As String

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then Exit Sub
    If Not swModel.GetType = swDocDRAWING Then Exit Sub

    Set swSelMgr = swModel.SelectionManager

    For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)

        selType = swSelMgr.GetSelectedObjectType3(i, -1)

        If selType <> 98 Then
            MsgBox "Please select a cel from BOM!"
            Exit Sub
        End If

        Set swTblAnn = swSelMgr.GetSelectedObject6(i, -1)
        Set swBOMTbl = swTblAnn

        swTblAnn.GetCellRange frtRow, lstRow, frtCol, lstCol

        For Row = frtRow To lstRow
            CfgName = swBOMTbl.BomFeature.GetConfigurations(True, True)(0)
            vComps = swBOMTbl.GetComponents2(Row, CfgName)
            If Not IsEmpty(vComps) Then
                Set swComp = swBOMTbl.GetComponents2(Row, CfgName)(0)
                openComponentDrawing swComp
            End If
        Next Row

    Next i
End Sub

Private Function openComponentDrawing(swComp As Component2)

    Dim compPath As String
    compPath = swComp.GetPathName
    
    Dim drwPath As String
    drwPath = Left(compPath, InStrRev(compPath, ".") - 1) & ".slddrw"
 
    ' Try Open Drawing
    Dim swDrw As SldWorks.DrawingDoc
    Dim errors As Long, warnings As Long
    Set swDrw = swApp.OpenDoc6(drwPath, swDocDRAWING, 0, "", errors, warnings)
    
    If errors <> 0 Then
        If errors = 2 Then
            Dim partNumber As String
            partNumber = Right(drwPath, Len(drwPath) - InStrRev(drwPath, "\"))
            partNumber = Left(partNumber, InStrRev(partNumber, ".") - 1)
            MsgBox "Couldn't find drawing for following part number: " & partNumber
        End If
    Else
        swApp.ActivateDoc3 drwPath, False, 0, errors
    End If
    
End Function