15 Replies Latest reply on Apr 7, 2017 3:42 PM by Alexey Kovalov

    Macro find geometry with dangling relations on drawing

    Alexey Kovalov
    Alexey Kovalov Feb 16, 2017 5:53 AM
      Hello all!

       

      There is useful macro made by handleman (http://www.eng-tips.com/viewthread.cfm?qid=368678). Its find dangling dimension, select it and magnify its area.

      Is it possible to change it macro or make new one for dangling geometry relations? Find, select and magnify. Dangling dimensions on drawing changes its color and dangling relations have no any visual changes.

      On example pictures I have a plate with axis of symmetry with relation "symmetric" (Screenshot_1) and point with "intersection" (2). After losing right face of part dimension "120" bacame dangling and change its color (on green in my settings - Screen_3). And axis of symmetry stay black but have dangling relation (Screen_4) and now its not axis of symmetry of the part. And all dimensions from this axis is wrong.

      The same with point (5).

      Thanks in advance.

      Alexey

       

      • 2079 Views
      • Tags:
        • Re: Macro find geometry with dangling relations on drawing
          Raghvendra Bhargava
          Raghvendra Bhargava Feb 16, 2017 1:17 PM (in response to Alexey Kovalov)

          Relations are always attached to entities so instead of magnifying relations, we can select and magnify Related entities.

          • Re: Macro find geometry with dangling relations on drawing
            Alexey Kovalov
            Alexey Kovalov Mar 24, 2017 9:26 AM (in response to Alexey Kovalov)

            Hello!

            In macro by handleman (see first post) dangling dimensions finding and magnifing by means of code

            For i = i To UBound(aShts)

                 swDwg.ActivateSheet aShts(i)

                 Set swView = swDwg.GetFirstView

                 While Not (swView Is Nothing)

                     Set swAnnot = swView.GetFirstAnnotation3

                     While Not swAnnot Is Nothing

                         If swAnnot.IsDangling Then

                             swAnnot.Select3 False, Nothing

                             swDoc.ViewZoomToSelection

                             Exit For

                         End If

                         Set swAnnot = swAnnot.GetNext3

                     Wend

                     Set swView = swView.GetNextView

            How must I change it to find entities with dangling relations and magnify its?

            Regards,

            Alexey

              • Re: Macro find geometry with dangling relations on drawing
                Raghvendra Bhargava
                Raghvendra Bhargava Mar 24, 2017 1:18 PM (in response to Alexey Kovalov)

                Hi Alexey,

                Maybe this is what you are looking for:

                 

                Dim swApp   As SldWorks.SldWorks

                Dim Count   As Integer

                Dim swModel As ModelDoc2

                Dim vEnt    As Variant

                Dim vEntTyp As Variant

                Dim swAnnot As Annotation

                Dim swDw    As DrawingDoc

                Dim swView  As View

                 

                Sub main()

                 

                Set swApp = Application.SldWorks

                Set swModel = swApp.ActiveDoc

                Set swDw = swModel

                 

                Set swView = swDw.GetFirstView

                Set swView = swView.GetNextView

                 

                While Not (swView Is Nothing)

                    Set swAnnot = swView.GetFirstAnnotation3

                    While Not swAnnot Is Nothing

                        If swAnnot.IsDangling Then

                            Debug.Print swAnnot.GetAttachedEntityCount3

                            vEnt = swAnnot.GetAttachedEntities3     'Getting Entities

                            vEntTyp = swAnnot.GetAttachedEntityTypes     'Gettign Entities Types

                            swAnnot.Select3 False, Nothing

                            swModel.ViewZoomToSelection

                            'Exit For

                        End If

                        Set swAnnot = swAnnot.GetNext3

                    Wend

                    Set swView = swView.GetNextView

                   Wend

                End Sub

                  • Re: Macro find geometry with dangling relations on drawing
                    Alexey Kovalov
                    Alexey Kovalov Mar 24, 2017 9:31 PM (in response to Raghvendra Bhargava)

                    Hi, Raghvendra!

                    Thank you for your time.

                    Added your code to the macro, but unfortunately it does not work.

                    On the drawing still there is an axial line with a dangling relation (see attached pictures), but the macro does not find it.

                    Below is the full code of the macro, maybe I made a mistake somewhere?

                     

                      Dim swApp As SldWorks.SldWorks

                      Dim Count   As Integer

                      Dim vEnt    As Variant

                    Dim vEntTyp As Variant

                    Dim swDoc As SldWorks.ModelDoc2

                    Dim swDwg As SldWorks.DrawingDoc

                    Dim swView As SldWorks.View

                    Dim sMsg As String

                    Dim aShts As Variant

                    Dim swAnnot As SldWorks.Annotation

                    Dim swSht As SldWorks.Sheet

                     

                    Sub FindNextDangler()

                    Set swApp = Application.SldWorks

                    Set swDoc = swApp.ActiveDoc

                     

                    If swDoc.GetType <> swDocDRAWING Then

                         MsgBox "This macro only works for drawing files."

                         Exit Sub

                    End If

                     

                    Set swDwg = swDoc

                    aShts = swDwg.GetSheetNames

                     

                    For i = 0 To UBound(aShts)

                         Set swSht = swDwg.GetCurrentSheet

                         If aShts(i) = swSht.GetName Then

                             Exit For

                         End If

                    Next i

                     

                    For i = i To UBound(aShts)

                         swDwg.ActivateSheet aShts(i)

                         Set swView = swDwg.GetFirstView

                         Set swView = swView.GetNextView

                         While Not (swView Is Nothing)

                        Set swAnnot = swView.GetFirstAnnotation3

                        While Not swAnnot Is Nothing

                            If swAnnot.IsDangling Then

                                Debug.Print swAnnot.GetAttachedEntityCount3

                                vEnt = swAnnot.GetAttachedEntities3     'Getting Entities

                                vEntTyp = swAnnot.GetAttachedEntityTypes     'Gettign Entities Types

                                swAnnot.Select3 False, Nothing

                                swModel.ViewZoomToSelection

                                'Exit For

                            End If

                            Set swAnnot = swAnnot.GetNext3

                        Wend

                        Set swView = swView.GetNextView

                       Wend

                         If i <> UBound(aShts) Then

                             MsgBox "No more danglers on " & aShts(i) & ". Switching to " & aShts(i + 1)

                         Else

                             MsgBox "No more danglers found in this drawing."

                         End If

                    Next i

                     

                    Set swSht = Nothing

                    Set swAnnot = Nothing

                    Set swDoc = Nothing

                    Set swDwg = Nothing

                    Set swApp = Nothing

                    Set swView = Nothing

                     

                    End Sub