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 »