Hallo
Ich hätte gerne Hilfe, um eine Notiz (auf mehreren Blättern) zu finden und zu löschen, die mit "Burn*" beginnt
Ich kann die Notiz finden, aber vorerst nicht auswählen und löschen, es gibt wahrscheinlich etwas sehr Einfaches, das ich nicht verstehe:
'--------------------------------------------
' 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
Mit ein wenig Recherche ist hier ein fast funktionsfähiger 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
Ich habe nur ein Problem, weil die Anmerkung in jedem Blatt doppelt vorhanden ist und die 1. nur dann gelöscht wird, wenn jemand versteht, warum.
Momentan führe ich das Makro 2 Mal aus, um jedes MEP zu reinigen (mehrere hundert Blätter...)
Hallo
Ich habe den gleichen Track getestet, also ist die Tatsache, dass der zweite nicht gelöscht wird, die Tatsache, dass swNote leer ist, sobald die Notiz gelöscht wird.
Unten sehen Sie den korrigierten Code mit dem Zusatz eines booleschen Werts, um die Fortsetzung der Notenanalyse zu handhaben.
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
Bearbeiten: Wenn die Notizen nicht systematisch im Hintergrund sind, sollten Sie auch darüber nachdenken, die Ansichten in einer Schleife zu wiederholen.
1 „Gefällt mir“
Die Notizen (in diesem Fall im Hintergrund)
Die vorgeschlagene Lösung ist perfekt funktionsfähig. Vielen Dank
1 „Gefällt mir“