Makro Wybierz element odniesienia, tolerancję geometryczną i numer pozycji

Out of category
1

Witam wszystkich,

 

Zacząłem od istniejącego makra, zmodyfikowałem je tak, aby przypisywać warstwy zgodnie z wybranym elementem.

Nie  mogę znaleźć sposobu na przypisanie elementu odniesienia do warstwy, tolerancji geometrycznej.

Wszystkie adnotacje muszą być zaznaczone

W załączeniu znajduje się makro

 

Z góry dziękuję za pomoc

 

Yannicka

 


changer_fdp_.swp
2

Jak rozumiem, makro działa z wyjątkiem tolerancji geometrycznych. W takim przypadku zamień:        Set swAnn = swGtol.Gtol
przez :       Set swAnn = swGtol.GetAnnotation

1 polubienie
3

Testuję dziś po południu

Dziękuję

Yannicka

4

Właśnie przetestowałem

Działa dla tolerancji geometrycznych

1. ale nie dla elementów odniesienia

2. Muszę również wybrać wszystkie tabele znajdujące się na moim rysunku.

Czy istnieje wiersz poleceń  do identyfikowania wszystkich tabel?

 

3.Is możliwość wyboru wszystkich wymiarów, adnotacji, tolerancji, tabeli.... z makrem, którego używam? Ctrl A nie jest brany pod uwagę przez rejestrator makr.

 

Dziękuję

5

1. Dla elementów referencyjnych używa

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

2. do przechodzenia przez tabele możesz użyć GetTableAnnotations

3. Aby przejść przez wszystkie adnotacje, możesz użyć GetFirstDisplayDimension i NextDisplayDimension zobacz: https://help.solidworks.com/2018/English/api/sldworksapi/Traverse_Annotations_Example_VB.htm

1 polubienie
6

Cześć Jerome,

Dziękujemy za opinię.

 

Nie ma problemu dla punktu 1

Punkt 2 nie jest jednak brany pod uwagę.

 

                ElseIf TypeOf swSelObj Is SldWorks.TableAnnotation then
                    
                    Dim swAnnTable  As SldWorks.TableAnnotation
                    Set swAnnTable = swSelObj
                    Set swAnn = swAnnTable.GetTableAnnotations
                    swAnn.Layer = nazwa_warstwy

 

Brak wyboru zestawienia komponentów lub listy części spawanych.

Skąd to mogło się wziąć?

 

W przyszłym tygodniu poszukam pozycji 3

Dziękujemy za Twoją opinię.

 

Yannicka

 

 


changer_fdp_.swp
7

Funkcja GetTableAnnotations zwraca listę. Każdy z nich musi być następnie traktowany indywidualnie.

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

Aby umieścić każdą tabelę, adnotację, wymiar, segment itp. każdego arkusza i każdego widoku, bez konieczności ich wybierania, spróbuj tego: 

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 polubienie