Witam
Potrzebuję pomocy w znalezieniu i usunięciu notatki (na kilku arkuszach), która zaczyna się od "Nagraj*"
Mogę znaleźć notatkę, ale na razie jej nie zaznaczam i nie usuwam, prawdopodobnie jest coś bardzo prostego, czego nie rozumiem:
'--------------------------------------------
' 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
Po odrobinie badań, oto prawie funkcjonalny kod:
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
Mam tylko jeden problem, ponieważ adnotacja jest zduplikowana w każdym arkuszu i usuwa tylko 1. jeśli ktoś zrozumie dlaczego.
Obecnie uruchamiam makro 2 razy, aby wyczyścić każdą instalację (kilkaset arkuszy...)
Witam
Testowałem tę samą ścieżkę, więc to, że nie usuwa drugiej, to fakt, że po usunięciu notatki swNote jest pusty.
Poniżej znajduje się poprawiony kod z dodatkiem wartości logicznej do obsługi kontynuacji analizy oceny.
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
Edycja: Jeśli nuty nie są systematycznie w tle, powinieneś również pomyśleć o zapętleniu widoków.
1 polubienie
Notatki (w tym przypadku są w tle)
Proponowane rozwiązanie jest w pełni funkcjonalne. Dziękuję
1 polubienie