Macro Select Reference Element, Geometric Tolerance, and Balloon

Hello everyone,

 

I started from an existing macro, I modified it to assign layers according to the selected element.

I can't  find how to assign a layer reference element, geometric tolerance.

All annotations must be selected

Attached is the macro

 

Thank you in advance for your help

 

Yannick

 


changer_fdp_.swp

As I understand it, the macro works except for geometric tolerances. In this case replace:        Set swAnn = swGtol.Gtol
by :       Set swAnn = swGtol.GetAnnotation

1 Like

I'm testing this afternoon

Thank you

yannick

I just tested

It works for geometric tolerances

1. but not for reference elements

2. I also need to select all the tables present in my Drawing.

Is there a command  line to identify all tables?

 

3.Is it possible to select all the dimensions, annotations, tolerances, table.... with the macro I use? Ctrl A is not taken into account by the macro recorder.

 

Thank you

1. For reference items uses

ElseIf TypeOf swSelObj Is SldWorks.DatumTag Then
   Dim swDatum As SldWorks.DatumTag
   Set swDatum = swSelObj
   Set swAnn = swDatum.GetAnnotation
   swAnn.Layer = layerName

2. to traverse tables you can use GetTableAnnotations

3. to go through all the annotations you can use GetFirstDisplayDimension and NextDisplayDimension see: https://help.solidworks.com/2018/English/api/sldworksapi/Traverse_Annotations_Example_VB.htm

1 Like

Hi Jerome,

Thank you for the feedback.

 

No problem for point 1

However, point 2 is not taken into account.

 

                ElseIf TypeOf swSelObj Is SldWorks.TableAnnotation Then
                    
                    Dim swAnnTable  As SldWorks.TableAnnotation
                    Set swAnnTable = swSelObj
                    Set swAnn = swAnnTable.GetTableAnnotations
                    swAnn.Layer = layerName

 

No selection of a BOM or welded parts list.

Where could this come from?

 

I'll look next week for item 3

Thank you for your feedback.

 

Yannick

 

 


changer_fdp_.swp

GetTableAnnotations returns a list. Each one must then be treated individually.

Dim swView      As SldWorks.View
Dim swTables    As Variant
Dim swTable     As Variant
Dim swTableAnn  As SldWorks.TableAnnotation
Set swView = swDraw.GetFirstView
If swView.GetTableAnnotationCount > 0 Then
   swTables = swView.GetTableAnnotations
   For Each swTable In swTables
      Set swTableAnn = swTable
      Set swAnn = swTableAnn.GetAnnotation
      swAnn.Layer = layerName
   next
End If

 

To put each table, annotation, dimension, segment, etc. of each sheet and each view, without having to select them, try this:

Option Explicit
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swDraw As SldWorks.DrawingDoc
    Dim vSheets As Variant
    Dim vSheet As Variant
    Dim swView As SldWorks.View
    Dim swAnn As SldWorks.Annotation
    Dim swNote As SldWorks.Note
    Dim swDispDim As SldWorks.DisplayDimension
    Dim swGtol As SldWorks.Gtol
    Dim swDatum As SldWorks.DatumTag
    Dim swAnnSFSymbol As SldWorks.SFSymbol
    Dim swTables As Variant
    Dim swTable As Variant
    Dim swTableAnn As SldWorks.TableAnnotation
    Dim swSketch As SldWorks.Sketch
    Dim vSegs As Variant
    Dim vSeg As Variant
    Dim swSkSeg As SldWorks.SketchSegment
    Dim vPts As Variant
    Dim vPt As Variant
    Dim swSkPt As SldWorks.SketchPoint
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "Ouvrir une mise en plan"
        Exit Sub
    End If
    If swModel.GetType <> swDocumentTypes_e.swDocDRAWING Then
        MsgBox "Ouvrir une mise en plan"
        Exit Sub
    End If
    
    Set swDraw = swModel
    
    vSheets = swDraw.GetSheetNames
    For Each vSheet In vSheets
        swDraw.ActivateSheet vSheet
    
        Set swView = swDraw.GetFirstView
    
        If swView.GetTableAnnotationCount > 0 Then
            swTables = swView.GetTableAnnotations
            For Each swTable In swTables
               Set swTableAnn = swTable
               Set swAnn = swTableAnn.GetAnnotation
               swAnn.Layer = "Annotations"
            Next
        End If

        Set swView = swView.GetNextView
        While Not swView Is Nothing
            Set swNote = swView.GetFirstNote
            While Not swNote Is Nothing
                Set swAnn = swNote.GetAnnotation
                swAnn.Layer = "Annotations"
                Set swNote = swNote.GetNext
            Wend

            Set swDatum = swView.GetFirstDatumTag
            While Not swDatum Is Nothing
                Set swAnn = swDatum.GetAnnotation
                swAnn.Layer = "Annotations"
                Set swDatum = swDatum.GetNext
            Wend
        
            Set swGtol = swView.GetFirstGTOL
            While Not swGtol Is Nothing
                Set swAnn = swGtol.GetAnnotation
                swAnn.Layer = "Annotations"
                Set swGtol = swGtol.GetNextGTOL
            Wend

            Set swAnnSFSymbol = swView.GetFirstSFSymbol
            While Not swAnnSFSymbol Is Nothing
                Set swAnn = swAnnSFSymbol.GetAnnotation
                swAnn.Layer = "Annotations"
                Set swAnnSFSymbol = swAnnSFSymbol.GetNext
            Wend
        
            Set swDispDim = swView.GetFirstDisplayDimension5
            While Not swDispDim Is Nothing
                Set swAnn = swDispDim.GetAnnotation
                swAnn.Layer = "Annotations"
                Set swDispDim = swDispDim.GetNext5
            Wend

            Set swSketch = swView.GetSketch
        
            vSegs = swSketch.GetSketchSegments
            If Not IsEmpty(vSegs) Then
                For Each vSeg In vSegs
                    Set swSkSeg = vSeg
                    swSkSeg.Layer = "Dessin"
                Next
            End If
        
            vPts = swSketch.GetSketchPoints2
            If Not IsEmpty(vPts) Then
                For Each vPt In vPts
                    Set swSkPt = vPt
                    swSkPt.Layer = "Dessin"
                Next
            End If
        
            Set swView = swView.GetNextView
        Wend
    Next
    swModel.ClearSelection2 True
End Sub

 

1 Like