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