Macro selectionner element de reference, tolerance géométrique et bulle

Bonjour a tous,

 

Je suis partie d'une macro existante, je l'ai modifiée pour affecter des calques suivant les élément sélectionné.

Je ne trouve pas comment affecter un calque  élément de référence, tolérance géométrique.

Il faut sélectionner toutes les annotations

Ci joint la macro

 

Merci d'avance de votre aide

 

Yannick

 


changer_fdp_.swp

Si je comprend bien, la macro fonctionne sauf pour les tolérances géométriques. Dans ce cas remplace:        Set swAnn = swGtol.Gtol
par :       Set swAnn = swGtol.GetAnnotation

1 « J'aime »

Je teste cette après midi

Merci

yannick

Je viens de tester

Ca fonctionne pour les tolérances géométrique

1. mais pas les pour les éléments de référence

2. Je dois également sélectionner toutes les tables présentent dans ma Mise en plan.

Y a t il une ligne de commande  pour identifier toutes les tables?

 

3.Est t il possible de sélectionner tous les dimensions ,annotations, tolérances, table.... avec la macro que j'utilise ? Ctrl A n est pas pris en compte par l enregistreur de macro.

 

Merci

1. Pour les éléments de référence utilise

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

2. pour traverser les tables tu peux utiliser GetTableAnnotations

3. pour traverser toute les annotation tu peux utiliser GetFirstDisplayDimension et NextDisplayDimension voir: https://help.solidworks.com/2018/English/api/sldworksapi/Traverse_Annotations_Example_VB.htm

1 « J'aime »

salut Jérome,

Merci pour le retour.

 

Pas de probleme pour le point 1

Par contre le point 2 n'est pas pris en compte.

 

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

 

Pas de sélection d'une bom ou liste de pièce soudées.

Serais tu d'ou cela peut provenir?

 

Je vais regarder la semaine prochaine pour le point 3

Merci pour tes retours.

 

Yannick

 

 


changer_fdp_.swp

GetTableAnnotations retourne une liste. Il faut ensuite traiter chacune individuellement.

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

 

Pour mettre sur un calque spécifique chaque table, annotation, dimension, segment, etc... de chaque feuille et chaque vue, sans avoir à les sélectionner, essaye ca:

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 « J'aime »