Macro Selecteer Referentie-element, Geometrische tolerantie en Ballon

Out of category
1

Hallo allemaal,

 

Ik ben begonnen met een bestaande macro, ik heb deze aangepast om lagen toe te wijzen op basis van het geselecteerde element.

Ik kan niet  vinden hoe ik een laagreferentie-element, geometrische tolerantie, moet toewijzen.

Alle annotaties moeten zijn geselecteerd

Bijgevoegd is de macro

 

Bij voorbaat dank voor uw hulp

 

Yannick

 


changer_fdp_.swp
2

Zoals ik het begrijp, werkt de macro behalve geometrische toleranties. Vervang in dit geval:        Set swAnn = swGtol.Gtol
door :       Set swAnn = swGtol.GetAnnotation

1 like
3

Ik ben vanmiddag aan het testen

Bedankt

Yannick

4

Ik heb net getest

Het werkt voor geometrische toleranties

1. maar niet voor referentie-elementen

2. Ik moet ook alle tabellen selecteren die in mijn tekening aanwezig zijn .

Is er een opdrachtregel  om alle tabellen te identificeren?

 

3.Is het mogelijk om alle afmetingen, annotaties, toleranties, tabel.... met de macro die ik gebruik? Ctrl A wordt niet in aanmerking genomen door de macrorecorder.

 

Bedankt

5

1. Gebruik voor referentie-items

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

2. om tabellen te doorlopen kunt u GetTableAnnotations gebruiken

3. om alle annotaties te doorlopen die u kunt gebruiken GetFirstDisplayDimension en NextDisplayDimension zie: https://help.solidworks.com/2018/English/api/sldworksapi/Traverse_Annotations_Example_VB.htm

1 like
6

Hoi Hiëronymus,

Bedankt voor de feedback.

 

Geen probleem voor punt 1

Er wordt echter geen rekening gehouden met punt 2.

 

                ElseIf TypeOf swSelObj is SldWorks.TableAnnotation then
                    
                    Dim swAnnTable  als SldWorks.TableAnnotation
                    Stel swAnnTable in = swSelObj
                    Stel swAnn = swAnnTable.GetTableAnnotations in
                    swAnn.Layer = laagNaam

 

Geen selectie van een stuklijst of lijst met gelaste onderdelen.

Waar zou dit vandaan kunnen komen?

 

Ik zal volgende week kijken voor item 3

Bedankt voor je feedback.

 

Yannick

 

 


changer_fdp_.swp
7

GetTableAnnotations retourneert een lijst. Elk moet dan afzonderlijk worden behandeld.

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

Om elke tabel, annotatie, dimensie, segment, enz. Van elk blad en elke weergave, zonder ze te hoeven selecteren, probeer het volgende:

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