Solidworks macro to find and delete an anotation based on a value

Hello

I would like help to find and delete a note (on several sheets) that starts with "Burn*"

I can find the note, but not select and delete it for now, there is probably something very simple that I don't understand:

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

' 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

 

With a little research, here's an almost functional 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

 

I just have one problem because the annotation is duplicate in each sheet and it only deletes the 1st one if someone understands why.

Currently I run the macro 2 times to clean each MEP (several hundred sheets...)

Hello

I was testing the same track, so the fact that it doesn't delete the second one is the fact that once the note is deleted, swNote is empty.

Below is the corrected code with the addition of a boolean to handle the continuation of the grade analysis.

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

 

Edit: If the notes are not systematically in the background, you should also think about looping on the views.

1 Like

The notes (in this case are in the background)

The proposed solution is perfectly functional. Thank you

1 Like