Macro solidworks pour chercher et supprimer un anotation en fonction d'une valeur

Bonjour,

Je souhaiterais de l'aide afin de chercher et supprimer une note (sur plusieurs feuille) qui commence par "Graver*"

J'arrive à trouver la note, mais pas à la sélectionner et l'effacer pour l'instant, il y a surrement un truc tout bête que je ne comprend pas:

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

' 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

 

Avec un peu de recherche, voici un code presque fonctionnel:

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

 

Il me reste juste un soucis car l'annotation est en double dans chaque feuille et il ne me supprime que la 1èere si quelqu'un comprend pourquoi.

Actuellement je lance 2 fois la macro pour nettoyer chaque MEP (plusieurs centaine de feuilles...)

Bonjour,

J'étais en train de tester la même piste, donc pour le fait que ça ne supprime pas la seconde c'est le fait qu'une fois la suppression de la note effectuée, swNote est vide.

Ci-dessous le code corrigé avec l'ajout d'un booléen pour gérer la poursuite de l'analyse des notes.

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: Si les notes ne sont pas systématiquement dans le fond de plan, il faut également penser à boucler sur les vues.

1 « J'aime »

Les notes (dans ce cas là sont bien dans le fond de plan)

La solution proposée est parfaitement fonctionnelle. Merci

1 « J'aime »