Solidworks Makro zum Suchen und Löschen einer Anmerkung basierend auf einem Wert

Hallo

Ich hätte gerne Hilfe, um eine Notiz (auf mehreren Blättern) zu finden und zu löschen, die mit "Burn*" beginnt

Ich kann die Notiz finden, aber vorerst nicht auswählen und löschen, es gibt wahrscheinlich etwas sehr Einfaches, das ich nicht verstehe:

'--------------------------------------------

' Preconditions: Drawing document is open and at least

'                one view has some notes.

'

' Postconditions: None

'

' NOTE: IDrawingDoc::GetViews returns both sheets and views.

'----------------------------------------------

Option Explicit

 

Dim swApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim swDrawDoc As SldWorks.DrawingDoc

Dim swView As SldWorks.View

Dim swNote As SldWorks.Note

Dim sheetCount As Long

Dim viewCount As Long

Dim noteCount As Long

Dim i As Long

 

Sub main()

 

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

Set swDrawDoc = swModel

 

Dim viewCount As Long

viewCount = swDrawDoc.GetViewCount

 

Dim ss As Variant

ss = swDrawDoc.GetViews

 

For sheetCount = LBound(ss) To UBound(ss)

    Dim vv As Variant

    vv = ss(sheetCount)

 

    For viewCount = LBound(vv) To UBound(vv)

        Debug.Print (vv(viewCount).GetName2())

 

        Dim vNotes As Variant

        noteCount = vv(viewCount).GetNoteCount

 

        If noteCount > 0 Then

            vNotes = vv(viewCount).GetNotes

            For i = 0 To noteCount - 1

                Debug.Print "  Note text: " & vNotes(i).GetText
                If vNotes(i).GetText Like "Graver le N°*" Then
                MsgBox "ok"
                'Dim myAnnotation As SldWorks.Annotation
                
                'Set myAnnotation = myNote.GetAnnotation
                
                'myAnnotation.Select3 False, Nothing
                
                'Part.Extension.DeleteSelection2 1

                End If

            Next

        End If

 

    Next viewCount

 

Next sheetCount

 

End Sub

 

Mit ein wenig Recherche ist hier ein fast funktionsfähiger Code:

Option Explicit

Sub SupressNote()

Dim swApp                       As SldWorks.SldWorks
Dim swModel                     As SldWorks.ModelDoc2
Dim swDraw                      As SldWorks.DrawingDoc
Dim swView                      As SldWorks.View
Dim swNote                      As SldWorks.Note
Dim swAnn                       As SldWorks.Annotation
Dim bRet                        As Boolean
Dim mySheet                     As SldWorks.Sheet
Dim swSheet                     As SldWorks.Sheet
Dim vSheetNames                 As Variant
Dim i As Integer


    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swDraw = swModel
    
    Set swSheet = swDraw.GetCurrentSheet
    vSheetNames = swDraw.GetSheetNames

    
    For i = 0 To UBound(vSheetNames)
    Debug.Print vSheetNames(i)
    swDraw.ActivateSheet vSheetNames(i)
        
        
                    
                    Set swView = swDraw.GetFirstView ' This is the drawing template
                    Set swNote = swView.GetFirstNote
                
                    swModel.ClearSelection2 (True)
                
                    Debug.Print "File = " & swModel.GetPathName
                
                    Do While Not swNote Is Nothing
                        Debug.Print "Note:" & swNote.GetText
                        If swNote.GetText Like "Graver le N°*" Then
                            Set swAnn = swNote.GetAnnotation
                            bRet = swAnn.Select2(True, 0)
                            Debug.Print "  " & swNote.GetName
                            Debug.Print "    " & swNote.GetText
                            swModel.EditDelete
                        End If
                        Set swNote = swNote.GetNext
                    Loop
                    swModel.ClearSelection2 (True)
                    swDraw.ActivateSheet (swSheet.GetName)
    Next i
    'Supression du calques Notes rouges
     Dim lyrMgr As LayerMgr
     Set lyrMgr = swDraw.GetLayerManager
    bRet = lyrMgr.DeleteLayer("NotesRouge")
    
End Sub

 

Ich habe nur ein Problem, weil die Anmerkung in jedem Blatt doppelt vorhanden ist und die 1. nur dann gelöscht wird, wenn jemand versteht, warum.

Momentan führe ich das Makro 2 Mal aus, um jedes MEP zu reinigen (mehrere hundert Blätter...)

Hallo

Ich habe den gleichen Track getestet, also ist die Tatsache, dass der zweite nicht gelöscht wird, die Tatsache, dass swNote leer ist, sobald die Notiz gelöscht wird.

Unten sehen Sie den korrigierten Code mit dem Zusatz eines booleschen Werts, um die Fortsetzung der Notenanalyse zu handhaben.

Sub SupressNote()

Dim swApp                       As SldWorks.SldWorks
Dim swModel                     As SldWorks.ModelDoc2
Dim swDraw                      As SldWorks.DrawingDoc
Dim swView                      As SldWorks.View
Dim swNote                      As SldWorks.Note
Dim swAnn                       As SldWorks.Annotation
Dim bRet                        As Boolean
Dim mySheet                     As SldWorks.Sheet
Dim swSheet                     As SldWorks.Sheet
Dim vSheetNames                 As Variant
Dim bFind                       As Boolean
Dim i As Integer


    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swDraw = swModel
    
    Set swSheet = swDraw.GetCurrentSheet
    vSheetNames = swDraw.GetSheetNames
    
    
    For i = 0 To UBound(vSheetNames)
    Debug.Print vSheetNames(i)
    swDraw.ActivateSheet vSheetNames(i)
        
        
                    
                    Set swView = swDraw.GetFirstView ' This is the drawing template
                    Do While Not swView Is Nothing
                        Set swNote = swView.GetFirstNote
                
                        swModel.ClearSelection2 (True)
                
                        Debug.Print "File = " & swModel.GetPathName
                
                        Do While Not swNote Is Nothing
                            bFind = False
                            Debug.Print "Note:" & swNote.GetText
                            If swNote.GetText Like "*Chanfrein*" Then '"Graver le N°*" Then
                                bFind = True
                                Set swAnn = swNote.GetAnnotation
                                bRet = swAnn.Select2(True, 0)
                                Set swNote = swNote.GetNext
                                
                                Debug.Print "  " & swNote.GetName
                                Debug.Print "    " & swNote.GetText
                                swModel.EditDelete
                                
                            End If
                        If Not bFind Then Set swNote = swNote.GetNext
                        Loop
                    Set swView = swView.GetNextView
                    Loop
                    swModel.ClearSelection2 (True)
                    swDraw.ActivateSheet (swSheet.GetName)
    Next i
    'Supression du calques Notes rouges
     Dim lyrMgr As LayerMgr
     Set lyrMgr = swDraw.GetLayerManager
    bRet = lyrMgr.DeleteLayer("NotesRouge")
    
End Sub

 

Bearbeiten: Wenn die Notizen nicht systematisch im Hintergrund sind, sollten Sie auch darüber nachdenken, die Ansichten in einer Schleife zu wiederholen.

1 „Gefällt mir“

Die Notizen (in diesem Fall im Hintergrund)

Die vorgeschlagene Lösung ist perfekt funktionsfähig. Vielen Dank

1 „Gefällt mir“