Makro dodawanie notatek zgodnie z formatem konspektu

sbadenis · 25 Październik 2019 11:38

Witam

Po otwarciu planu chciałbym wykonać kilka z następujących kroków:

1- Sprawdź format planu (A4H, A3H...)

2-W zależności od formatu arkusza dodaj adnotację (z tekstem w kolorze czerwonym i prostokątnym polem wokół niego) o różnych współrzędnych w zależności od formatu

3-Loop na następnym arkuszu.

Na razie udaje mi się stworzyć notatkę w arkuszu, ale w kolorze czarnym, bez pudełka i bez prostokątnej ramki wokół niego i dlatego prosiłbym o pomoc przy tej 1. modyfikacji:

A-) Zmień tekst na czerwony i prostokątne pole wokół niego

B-) Przykład lub funkcje, których należy użyć, aby uruchomić mój kod zgodnie z formatem arkusza

C-) przykład, który zapętla się na kilku arkuszach

Mam nadzieję, że dzięki różnym elementom w końcu uda mi się osiągnąć to makro pomimo mojego początkującego poziomu w VBA.

Mój bardzo uproszczony kod do tej pory:

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim str As String

    ' Constant enumerators
    Const swDocPART = 1
    Const swDocASSEMBLY = 2
    Const swDocDRAWING = 3

    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        ' If no model currently loaded, then exit
        Exit Sub
    End If

    ' Determine the document type
    ' If the document is not a drawing, then send a message to the user
    If (swModel.GetType <> swDocDRAWING) Then
        swApp.SendMsgToUser ("Macro only used for drawings")
        Exit Sub
    End If

    ' Compose text string with carriage return
    str = "Traçabilité" + Chr(10) + "Matière"

    ' Insert note at (x=0.138m,y=0.285m) on the sheet
    swModel.CreateText str, 0.138, 0.285, 0.5, 0.005, 0

End Sub

Z góry dziękuję za wszystkie uwagi, które pomogą mi posunąć się naprzód w tym temacie.

sbadenis · 25 Październik 2019 13:16

Odpowiadam sobie na pętlę:

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim str As String
    'i = 0

    
    
    ' Constant enumerators
    Const swDocPART = 1
    Const swDocASSEMBLY = 2
    Const swDocDRAWING = 3

    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        ' If no model currently loaded, then exit
        Exit Sub
    End If

    ' Determine the document type
    ' If the document is not a drawing, then send a message to the user
    If (swModel.GetType <> swDocDRAWING) Then
        'swApp.SendMsgToUser ("Utiliser cette macro uniquement pour une MEP")
        MsgBox "Utiliser cette macro uniquement pour une MEP.", vbCritical, "Mauvais type de document ouverth"
        Exit Sub
    End If

    ' Compose text string with carriage return
    str = "Traçabilité" + Chr(10) + "Matière"

 

    'SD modif on boucle sur chaque feuille
        Set Document = swApp.ActiveDoc        ' On récupère le document d'ouvert
        Set swSht = Document.GetCurrentSheet
    sThisSheet = swSht.GetName

    iSheets = Document.GetSheetCount
    sSheetNames = Document.GetSheetNames
        
                For i = 0 To iSheets - 1
                
                            MsgBox i
                            If sSheetNames(i) <> sThisSheet Then
                            Document.ActivateSheet sSheetNames(i)
                            End If
                            ' Insert note at (x=0.138m,y=0.285m) on the sheet
                            swModel.CreateText str, 0.138, 0.285, 0.5, 0.005, 0
                Next i


End Sub

Pozostaje jeszcze format do sprawdzenia i formatowanie notatki (kolor + pole)

stefbeno · 25 Październik 2019 12:24

Jeśli chodzi o kolor, wydaje mi się, że trzeba umieścić obiekt w określonej warstwie (przynajmniej tak zrobiłem, kiedy tego potrzebowałem).

Kiedy muszę zrobić makro, często przeglądam rejestrator, pozwala mi to łatwo pobrać fragmenty kodu dotyczące podstawowych operacji, na przykład aby utworzyć ramkę wokół tekstu, jeśli pole jest częścią adnotacji (sekcja konspektu).

sbadenis · 25 Październik 2019 13:25

stefbeno Próbowałem rejestratora, aby utworzyć notatkę z tekstem + kolor + ramka i wynik: puste makro...

O ile mój dyktafon się nie zepsuł, to niestety nie było to zbyt przekonujące...

Ale i tak dziękuję za radę.

d_roger · 25 Październik 2019 17:49

Witam

Powinieneś być w stanie użyć poniższego kodu, aby zrobić to, co chcesz (bądź ostrożny, nie zadbałem o obsługę błędów), zmieniam tylko pozycję tekstu zgodnie z formatem, ale możesz również zmienić tekst, w tym celu definiujesz zmienną łańcuchową, którą wypełniasz żądanym tekstem w każdym "Case", a następnie przenosisz tę zmienną do funkcji "insertionNote" zamiast zakodowanego na stałe tekstu. Nie skomentowałem kodu, ale wiem, że będziesz wiedział, jak go odczytać.

Option Explicit

Dim swApp                       As SldWorks.SldWorks
Dim swModel                     As SldWorks.ModelDoc2
Dim swDraw                      As SldWorks.DrawingDoc
Dim swSketchBlockDef            As SldWorks.SketchBlockDefinition
Dim swBlockInst                 As SldWorks.SketchBlockInstance
Dim swSketchMgr                 As SldWorks.SketchManager
Dim swModelDocExt               As SldWorks.ModelDocExtension
Dim swSheet                     As SldWorks.Sheet
Dim mySheet                     As SldWorks.Sheet
Dim paperSize                   As swDwgPaperSizes_e
Dim myBlockDefinition           As Object
Dim vSheetNames                 As Variant
Dim bRet                        As Boolean
Dim i                           As Long
Dim swMathUtil                  As SldWorks.MathUtility
Dim swMathPoint                 As SldWorks.MathPoint
Dim width                       As Double
Dim height                      As Double
Dim nPt(2)                      As Double
Dim vPt                         As Variant
Dim posX                        As Double
Dim posY                        As Double
Dim nomDuBloc                   As String
 
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swDraw = swModel
    Set swSheet = swDraw.GetCurrentSheet
    vSheetNames = swDraw.GetSheetNames
    For i = 0 To UBound(vSheetNames)
        swDraw.ActivateSheet (vSheetNames(i))
        Set mySheet = swDraw.GetCurrentSheet
        paperSize = mySheet.GetSize(width, height)
        Select Case paperSize
            Case 0
                posX = 0.038
                posY = 0.285
            Case 1
                posX = 0.138
                posY = 0.285
            Case 2
                posX = 0.038
                posY = 0.185
            Case 3
                posX = 0.038
                posY = 0.105
            Case 4
                posX = 0.008
                posY = 0.2
            Case 5
                posX = 0.008
                posY = 0.15
            Case 6
                posX = 0.008
                posY = 0.007
            Case 7
                posX = 0.06
                posY = 0.18
            Case 8
                posX = 0.23
                posY = 0.03
            'Ainsi de suite jusqu'à Case 12
            '...
            Case Else
                Exit Sub
        End Select
        insertionNote swModel, posX, posY, "Mon test d'insertion d'une note"
        swDraw.GraphicsRedraw2
    Next i
    swDraw.ActivateSheet (swSheet.GetName)
End Sub

Sub insertionNote(swModel As ModelDoc2, X As Double, Y As Double, monTexte As String)
    Dim myNote As Note
    Dim myAnnotation As Annotation
    Dim boolstatus As Boolean
    Set myNote = swModel.insertNote(monTexte)
    If Not myNote Is Nothing Then
        boolstatus = myNote.SetBalloon(4, 0)
        Set myAnnotation = myNote.GetAnnotation()
        If Not myAnnotation Is Nothing Then
           boolstatus = myAnnotation.SetPosition(X, Y, 0)
        End If
    End If
    ListeCalque swDraw, myAnnotation
End Sub

Sub ListeCalque(swModel As DrawingDoc, myAnnotation As Annotation)
    Dim swLayerMgr As SldWorks.LayerMgr
    Dim vLayerArr As Variant
    Dim vLayer As Variant
    Dim swLayer As SldWorks.Layer
    Dim noteLayer As Integer
    Dim layerExist As Boolean
    Set swLayerMgr = swModel.GetLayerManager
    vLayerArr = swLayerMgr.GetLayerList
    For Each vLayer In vLayerArr
        Set swLayer = swLayerMgr.GetLayer(vLayer)
        If swLayer.Name = "NotesRouge" Then
            layerExist = True
        Else
            layerExist = False
        End If
    Next
    If layerExist = True Then
        myAnnotation.Layer = "NotesRouge"
    Else
        noteLayer = swLayerMgr.AddLayer("NotesRouge", "Calque pour les notes rouge", RGB(255, 0, 0), 0, 0)
        myAnnotation.Layer = "NotesRouge"
    End If
End Sub

Pozdrowienia

sbadenis · 28 Październik 2019 12:48

Jeszcze raz dziękuję d.roger !

Zbliżam się do końca tego makra, ale są jeszcze 2 małe problemy do naprawienia:

- Chcę powiększyć czcionkę tekstu notatki, ale nie mogę znaleźć nic w pomocy, aby powiększyć tę notatkę (http://help.solidworks.com/2018/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.inote_members.html).

Chyba, że za tym tęsknię...

- Wreszcie dla koloru to nie działa. Tworzy warstwę z kolorem, ale adnotacja przyjmuje szare kolory...

A w trybie ręcznego tworzenia adnotacji, na odpowiedniej warstwie (czerwonej) adnotacja jest czerwona, ale zmienia kolor na szary po walidacji. Myślę, że pochodzi bardziej z opcji SW, ale nie mogę znaleźć, która.

Poza tym makro działa doskonale i udało mi się zrozumieć zdecydowaną większość z nich, a nawet zmodyfikować je poprzez usunięcie "pól", po prostu zastosowałem odejmowanie pozycji X i Y w stosunku do rozmiaru arkusza, co umieszcza adnotację w lewym górnym rogu każdego arkusza, tak jak chciałem i prościej.

d_roger · 28 Październik 2019 13:04

Witam

Ze względu na rozmiar czcionki notatki możesz zastąpić wstawienie podrzędne tym:

Sub insertionNote(swModel As ModelDoc2, X As Double, Y As Double, monBloc As String)
    Dim myNote As Note
    Dim myAnnotation As Annotation
    Dim swTextFormat As SldWorks.TextFormat
    Dim boolstatus As Boolean
    Set myNote = swModel.insertNote(monBloc)
    If Not myNote Is Nothing Then
        boolstatus = myNote.SetBalloon(4, 0)
        Set myAnnotation = myNote.GetAnnotation()
        If Not myAnnotation Is Nothing Then
            boolstatus = myAnnotation.SetPosition(X, Y, 0)
            Set swTextFormat = myAnnotation.GetTextFormat(1)
            swTextFormat.CharHeight = 0.02
            swTextFormat.Bold = True
            swTextFormat.Italic = True
            boolstatus = myAnnotation.SetTextFormat(1, False, swTextFormat)
        End If
    End If
    ListeCalque swDraw, myAnnotation
End Sub

Pozwala to na umieszczenie rozmiaru tekstu (tutaj 0,02 m), a także na wstawienie kursywy i pogrubienia, jeśli chcesz, inne opcje TUTAJ.

Jeśli chodzi o kolor, prawdopodobnie pochodzi on z opcji SW, ale na razie nie udało mi się znaleźć, która z nich, na moim komputerze kolor pozostaje w kolorze czerwonym...

Pozdrowienia

sbadenis · 28 Październik 2019 14:08

Bardzo dziękuję d.roger za cenną pomoc w tym temacie.

Skończyło się na tym, że wstawiłem tekst po mojej stronie z pożądanymi współrzędnymi, ale bez pola, koloru i rozmiaru czcionki.

Co więcej, mój kod był znacznie mniej zoptymalizowany.

Dla koloru, który nie jest dobry, składam zapytanie na infolinię i zobaczę, dlaczego to nie działa, bo ewidentnie gdzieś jest opcja, skoro ręcznie bez makra nie działa lepiej.

Oto ostateczny kod bez obsługi błędów, który niekoniecznie jest przydatny, ponieważ został uruchomiony z integracji (tylko na MEP)

Option Explicit

Dim swApp                       As SldWorks.SldWorks
Dim swModel                     As SldWorks.ModelDoc2
Dim swDraw                      As SldWorks.DrawingDoc
Dim swSketchBlockDef            As SldWorks.SketchBlockDefinition
Dim swBlockInst                 As SldWorks.SketchBlockInstance
Dim swSketchMgr                 As SldWorks.SketchManager
Dim swModelDocExt               As SldWorks.ModelDocExtension
Dim swSheet                     As SldWorks.Sheet
Dim mySheet                     As SldWorks.Sheet
Dim paperSize                   As swDwgPaperSizes_e
Dim myBlockDefinition           As Object
Dim vSheetNames                 As Variant
Dim bRet                        As Boolean
Dim i                           As Long
Dim swMathUtil                  As SldWorks.MathUtility
Dim swMathPoint                 As SldWorks.MathPoint
Dim width                       As Double
Dim height                      As Double
Dim nPt(2)                      As Double
Dim vPt                         As Variant
Dim posX                        As Double
Dim posY                        As Double
Dim nomDuBloc                   As String
Dim swTextFormat                As SldWorks.TextFormat



 
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swDraw = swModel
    Set swSheet = swDraw.GetCurrentSheet
    vSheetNames = swDraw.GetSheetNames

    
    For i = 0 To UBound(vSheetNames)
        'modifier ici le décalage en X et Y par rapport à l'angle en haut à gauche
        posX = 0.11
        posY = 0.013
        swDraw.ActivateSheet (vSheetNames(i))
        Set mySheet = swDraw.GetCurrentSheet
        paperSize = mySheet.GetSize(width, height)
        posX = width - posX
        posY = height - posY
        insertionNote swModel, posX, posY, "Traçabilité matière"
        swDraw.GraphicsRedraw2
        
    Next i
    swDraw.ActivateSheet (swSheet.GetName)
End Sub

Sub insertionNote(swModel As ModelDoc2, X As Double, Y As Double, monBloc As String)
    Dim myNote As Note
    Dim myAnnotation As Annotation
    Dim swTextFormat As SldWorks.TextFormat
    Dim boolstatus As Boolean
    Set myNote = swModel.InsertNote(monBloc)
    If Not myNote Is Nothing Then
        boolstatus = myNote.SetBalloon(4, 0)
        Set myAnnotation = myNote.GetAnnotation()
        If Not myAnnotation Is Nothing Then
            boolstatus = myAnnotation.SetPosition(X, Y, 0)
            Set swTextFormat = myAnnotation.GetTextFormat(1)
            swTextFormat.CharHeight = 0.008
            swTextFormat.Bold = True
            swTextFormat.Italic = True
            boolstatus = myAnnotation.SetTextFormat(1, False, swTextFormat)
        End If
    End If
    ListeCalque swDraw, myAnnotation
End Sub

Sub ListeCalque(swModel As DrawingDoc, myAnnotation As Annotation)
    Dim swLayerMgr As SldWorks.LayerMgr
    Dim vLayerArr As Variant
    Dim vLayer As Variant
    Dim swLayer As SldWorks.Layer
    Dim noteLayer As Integer
    Dim layerExist As Boolean
    Set swLayerMgr = swModel.GetLayerManager
    vLayerArr = swLayerMgr.GetLayerList
    For Each vLayer In vLayerArr
        Set swLayer = swLayerMgr.GetLayer(vLayer)
        If swLayer.Name = "NotesRouge" Then
            layerExist = True
        Else
            layerExist = False
        End If
    Next
    If layerExist = True Then
        myAnnotation.Layer = "NotesRouge"
    Else
        noteLayer = swLayerMgr.AddLayer("NotesRouge", "Calque pour les notes rouge", RGB(255, 0, 0), 0, 0)
        myAnnotation.Layer = "NotesRouge"
    End If
End Sub

Dziękuję bardzo

d_roger · 28 Październik 2019 21:40

Witam

Jeśli chodzi o kolor, upewnij się, że nie masz przycisku pola wyboru na pasku narzędzi "Format linii", patrz TUTAJ.

Pozdrowienia

sbadenis · 29 Październik 2019 06:52

Nie, nie jest aktywowany, najwyraźniej wynikałoby to bardziej z ustawienia koloru linii, który nie jest domyślny (pole nie jest zaznaczone) i nagle przyjmuje kolor szary.

Do potwierdzenia, bo nie miałem czasu na kopanie głębiej.

W każdym razie kolor jest mniej ważny niż reszta, więc potwierdzam twoją najbardziej odpowiednią odpowiedź.

tesniere53120 · 20 Luty 2020 11:04

Witam

Mam ten sam problem z kolorami co sbadenis, czy rozwiązałeś problem?

sbadenis · 20 Luty 2020 12:47

Nie rozwiązałem tego problemu.

Musiałem rozpocząć działalność bez koloru z powodu braku czasu i od tego czasu nie byłem w stanie przyjrzeć się problemowi.

Problem nie wynika z makra, ponieważ mogę je odtworzyć za pomocą mano.

Kiedy wpisuję adnotację w czerwoną warstwę, jest ona czerwona, a gdy tylko ją zweryfikuję, zmienia kolor na szary...

Z drugiej strony, jeśli znajdziesz rozwiązanie, jestem zainteresowany.