Makro "Referenzelement auswählen", "Geometrische Toleranz" und "Positionsnummer"

Out of category
1

Hallo an alle

 

Ich bin von einem vorhandenen Makro ausgegangen und habe es so geändert, dass ich Ebenen entsprechend dem ausgewählten Element zuweist.

Ich kann nicht  finden, wie man einem Layer-Referenzelement, geometrische Toleranz, zuweist.

Alle Anmerkungen müssen ausgewählt sein

Angehängt ist das Makro

 

Vielen Dank im Voraus für Ihre Hilfe

 

Yannick

 


changer_fdp_.swp
2

So wie ich es verstehe, funktioniert das Makro bis auf geometrische Toleranzen. Ersetzen Sie in diesem Fall:        Set swAnn = swGtol.Gtol
by :       Set swAnn = swGtol.GetAnnotation

1 „Gefällt mir“
3

Ich teste heute Nachmittag

Vielen Dank

Yannick

4

Ich habe gerade getestet

Es funktioniert für geometrische Toleranzen

1. jedoch nicht für Referenzelemente

2. Ich muss auch alle Tabellen auswählen, die in meiner Zeichnung vorhanden sind .

Gibt es eine Befehlszeile , um alle Tabellen zu identifizieren?

 

3.Is ist es möglich, alle Abmessungen, Anmerkungen, Toleranzen, Tabellen usw. auszuwählen. mit dem Makro, das ich verwende? Strg A wird vom Makrorekorder nicht berücksichtigt.

 

Vielen Dank

5

1. Für Referenzartikel wird

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

2. Um Tabellen zu durchlaufen, können Sie GetTableAnnotations verwenden

3. Um alle Anmerkungen durchzugehen, können Sie GetFirstDisplayDimension und NextDisplayDimension verwenden, siehe: https://help.solidworks.com/2018/English/api/sldworksapi/Traverse_Annotations_Example_VB.htm

1 „Gefällt mir“
6

Hallo Jerome,

Vielen Dank für das Feedback.

 

Kein Problem für Punkt 1

Punkt 2 wird jedoch nicht berücksichtigt.

 

                ElseIf TypeOf swSelObj ist SldWorks.TableAnnotation, dann
                    
                    Dim swAnnTable  As SldWorks.TableAnnotation
                    Set swAnnTable = swSelObj
                    Festlegen von swAnn = swAnnTable.GetTableAnnotations
                    swAnn.Layer = layerName

 

Keine Auswahl einer Stückliste oder geschweißten Stückliste.

Woher könnte das kommen?

 

Ich werde nächste Woche nach Punkt 3 suchen

Vielen Dank für Ihr Feedback.

 

Yannick

 

 


changer_fdp_.swp
7

GetTableAnnotations gibt eine Liste zurück. Jeder muss dann individuell behandelt werden.

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

 

8

 Um jede Tabelle, Anmerkung, Bemaßung, jedes Segment usw. Versuchen Sie für jedes Blatt und jede Ansicht, ohne sie auswählen zu müssen, Folgendes:

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 „Gefällt mir“