Hallo
Ik wil graag hulp bij het vinden en verwijderen van een notitie (op meerdere vellen) die begint met "Branden*"
Ik kan de notitie vinden, maar voorlopig niet selecteren en verwijderen, er is waarschijnlijk iets heel eenvoudigs dat ik niet begrijp:
'--------------------------------------------
' 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
Met een beetje onderzoek is hier een bijna functionele 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
Ik heb alleen een probleem, want de annotatie is dubbel in elk blad en het verwijdert alleen de 1e als iemand begrijpt waarom.
Momenteel voer ik de macro 2 keer uit om elke MEP schoon te maken (enkele honderden vellen...)
Hallo
Ik was dezelfde track aan het testen, dus het feit dat het de tweede niet verwijdert, is het feit dat zodra de notitie is verwijderd, swNote leeg is.
Hieronder vindt u de gecorrigeerde code met de toevoeging van een boolean om de voortzetting van de cijferanalyse af te handelen.
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: Als de notities niet systematisch op de achtergrond staan, moet je ook nadenken over looping op de weergaven.
1 like
De notities (in dit geval op de achtergrond)
De voorgestelde oplossing is perfect functioneel. Bedankt
1 like