AnsweredAssumed Answered

Macro to add balloon if two faces of two different parts is selected in drawing and add their custom properties to excel sheet

Question asked by Frank Van Eygen on Jan 30, 2019
Latest reply on Feb 6, 2019 by Frank Van Eygen

I am new to Solidworks VBA (not new to Excel VBA).

I would like to create a macro that adds a balloon to a drawing if two faces of two different parts (or connecting edge between two parts) are selected in a drawing (not in a part or assembly).

For each of the two selected parts in the drawing I would need the custom properties of those parts to be exported to an Excel file.

So in a drawing:

  1. click on 1 face
  2. click on 2nd face of different part
  3. place a balloon on the edge of the two parts (or on the loacation of a third click) with an ascending number
  4. export the balloon number and the custom properties of the two parts that one balloon refers to.

 

The code I have so far (a lot comes from this site):

 

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawModel As SldWorks.ModelDoc2
Dim Sheet As Object
Dim CusPropMgr As CustomPropertyManager
Dim swDwg As SldWorks.drawingDoc
Dim swView As SldWorks.View
Dim vCustPropNames As Variant
Dim strVal As String
Dim strResVal As String
Dim k As Integer
Dim myNote As SldWorks.Note
Dim myAnnotation As SldWorks.Annotation
Dim myTextFormat As Object
Dim boolstatus As Boolean
Dim longstatus  As Long
Sub Fire_Event_After_Selection_Made()
    'Select two faces, and this macro will create a balloon (hopefully)
   
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swDwg = swApp.ActiveDoc
   
    ' Determine the document type
    If swModel.GetType = swDocPART Then
        'do nothing
    ElseIf swModel.GetType = swDocASSEMBLY Then
        'do nothing
    ElseIf swModel.GetType = swDocDRAWING Then
        Set swSelMgr = swModel.SelectionManager
        If swSelMgr.GetSelectedObjectCount2(-1) <> 3 Then
            MsgBox "You must select 2 entities (excl drawingview), no more, no less"
            Exit Sub
        Else
            Dim selEdge1 As Integer
            Dim selEdge2 As Integer
            Dim selFace1 As Integer
            Dim selFace2 As Integer
            Dim selVertice1 As Integer
            Dim selVertice2 As Integer
            Dim selDrawingview As Integer
            'swSelEDGES=1
            'swSelFACES=2
            'swSelVERTICES=3
            'swSelDRAWINGVIEWS = 12
            Select Case swSelMgr.GetSelectedObjectType3(1, -1)
                Case 1
                    selEdge1 = 1
                Case 2
                    selFace1 = 2
                Case 3
                    selVertice1 = 3
                Case 12
                    selDrawingview = 12
            End Select
            Select Case swSelMgr.GetSelectedObjectType3(2, -1)
                Case 1
                    If selEdge1 = 0 Then
                        selEdge1 = 1
                    Else: selEdge2 = 1
                    End If
                Case 2
                    If selFace1 = 0 Then
                        selFace1 = 2
                    Else: selFace2 = 2
                    End If
                Case 3
                    If selVertice1 = 0 Then
                        selVertice1 = 3
                    Else: selVertice2 = 3
                    End If
                Case 12
                    selDrawingview = 12
            End Select
            Select Case swSelMgr.GetSelectedObjectType3(3, -1)
                Case 1
                    If selEdge1 = 0 Then
                        selEdge1 = 1
                    Else: selEdge2 = 1
                    End If
                Case 2
                    If selFace1 = 0 Then
                        selFace1 = 2
                    Else: selFace2 = 2
                    End If
                Case 3
                    If selVertice1 = 0 Then
                        selVertice1 = 3
                    Else: selVertice2 = 3
                    End If
                Case 12
                    selDrawingview = 12
            End Select
            If (selEdge1 <> swSelEDGES And selFace1 <> swSelFACES And selVertice1 <> swSelVERTICES) Or (selEdge2 <> swSelEDGES And selFace2 <> swSelFACES And selVertice2 <> swSelVERTICES) Then
                MsgBox "You must select only edges, faces or vertices"
                Exit Sub
            Else

               'create balloon:

                Set myNote = swModel.InsertNote("1") 'add ascending number for each time this macro runs
                If Not myNote Is Nothing Then
                    myNote.Angle = 0
                    boolstatus = myNote.SetBalloon(3, 2) 'place hexagon balloon
                    Set myAnnotation = myNote.GetAnnotation()
                    If Not myAnnotation Is Nothing Then
                        longstatus = myAnnotation.SetLeader3(swLeaderStyle_e.swSTRAIGHT, 1, True, False, False, False)
                        'boolstatus = myAnnotation.SetPosition(X + 0.01, Y + 0.01, Z) 'length and location of balloon needs to be adjusted
                        boolstatus = myAnnotation.SetTextFormat(0, True, myTextFormat)
                    End If
                End If
               
                'this part is not correct:
               
                'We assume here a simple case of the first view referring to the  desired model
                'The first view returned is the sheet--we'll skip that one
                Set swView = swDwg.GetFirstView
                Set swView = swView.GetNextView
                Set swDrawModel = swView.ReferencedDocument
                'this does not show the custom properties of the selected parts!!!
                'To extract a config specific property, give the config name as string
                Set CusPropMgr = swDrawModel.Extension.CustomPropertyManager("")
                vCustPropNames = CusPropMgr.GetNames
                If IsEmpty(vCustPropNames) = False Then
                    For k = 0 To UBound(vCustPropNames)
                        CusPropMgr.Get4 vCustPropNames(k), True, strVal, strResVal
                        Debug.Print k + 1 & ")  " & vCustPropNames(k) & " " & strVal & " " & strResVal
                    Next k
                End If
            End If
        End If
    End If
End Sub

 

Can somebody assist me in this please?

Frank

Outcomes