Macro notities toevoegen volgens het formaat van de omtrek

Out of category
1

Hallo

Nadat ik een plan heb geopend, wil ik een aantal van de volgende stappen uitvoeren:

1- Controleer het formaat van het plan (A4H, A3H...)

2-Afhankelijk van het formaat van het blad, voeg een annotatie toe (met tekst in rood en rechthoekig vak eromheen) met verschillende coördinaten, afhankelijk van het formaat

3-Loop op het volgende vel.

Voorlopig lukt het me om de notitie in een vel te maken maar in het zwart, zonder doos en zonder een rechthoekig kader eromheen en ik zou daarom graag hulp willen bij deze 1e wijziging:

A-) Verander de tekst in een rood en rechthoekig vak eromheen

B-)Een voorbeeld of de functies die ik moet gebruiken om mijn code te starten volgens het formaat van het blad

C-) een  voorbeeld dat over meerdere vellen loopt

Met zijn verschillende elementen hoop ik eindelijk deze macro te kunnen bereiken, ondanks mijn beginnersniveau in VBA.

Mijn zeer simplistische code tot nu toe:

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

Alvast bedankt voor alle bijdragen die mij verder zullen helpen met dit onderwerp.

2

Ik antwoord mezelf voor de lus:

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

Er is nog het formaat om te controleren en de opmaak van de notitie (kleur + vak)

3

Voor de kleur lijkt het mij dat je het object in een specifieke laag moet plaatsen (tenminste, dat is wat ik deed toen ik het nodig had).

Als ik een macro moet maken, ga ik vaak door de recorder, het stelt me in staat om gemakkelijk stukjes code op te halen over de basisbewerkingen bijvoorbeeld om het vak rond de tekst te maken, als het vak deel uitmaakt van de annotatie (overzichtssectie).
 

4

stefbeno Ik probeerde de recorder om een notitie te maken met Tekst + kleur + frame en resultaat: een lege macro...

Tenzij mijn recorder het verprutste, was het helaas niet erg overtuigend...

Maar toch bedankt voor het advies.

5

Hallo

Je zou de onderstaande code moeten kunnen gebruiken om te doen wat je wilt (wees voorzichtig, ik heb niet voor de foutafhandeling gezorgd), ik verander alleen de positie van de tekst volgens het formaat maar je kunt ook de tekst wijzigen, hiervoor definieer je een stringvariabele die je vult met de gewenste tekst in elke "Case" dan draag je deze variabele over naar de "insertionNote" functie in plaats van hardgecodeerde tekst. Ik heb geen commentaar gegeven op de code, maar ik weet dat je weet hoe je hem moet lezen.

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

Vriendelijke groeten

2 likes
6

Nogmaals bedankt d.roger !

Ik kom aan het einde van deze macro, maar er zijn nog 2 kleine problemen op te lossen:

- Ik wil het lettertype van de notitie vergroten, en ik kan niets vinden in de help om deze notitie te vergroten (http://help.solidworks.com/2018/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.inote_members.html).

Tenzij ik het mis...

- Ten slotte werkt het niet voor de kleur. Hij maakt de laag met de kleur, maar de annotatie neemt de grijze kleuren...

En in de modus voor het handmatig maken van annotaties is de annotatie in de juiste laag (rood) rood, maar verandert deze in grijs bij validatie. Ik denk dat het meer afkomstig is van een SW-optie, maar ik kan niet vinden welke.

 

Anders werkt de macro perfect en ben ik erin geslaagd om het overgrote deel ervan te begrijpen en zelfs om het te wijzigen met het verwijderen van de "vakken", ik heb zojuist een aftrekking van de X- en Y-positie toegepast in relatie tot de grootte van het blad dat de annotatie in de linkerbovenhoek van elk blad plaatst zoals ik wilde en eenvoudiger.

 

7

Hallo

Voor de lettergrootte van de notitie kun je de Sub insertionNote vervangen door deze:

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

Hiermee kunt u een tekstgrootte instellen (hier 0,02 m) en ook cursief en vet zetten als u wilt, andere opties HIER.

Voor de kleur komt het waarschijnlijk van een SW-optie, maar ik heb op dit moment niet kunnen vinden welke, op mijn pc blijft de kleur rood...

Vriendelijke groeten

1 like
8

Heel erg bedankt d.roger voor je kostbare hulp over dit onderwerp.

Ik had uiteindelijk de tekst aan mijn kant ingevoegd met de gewenste coördinaten, maar zonder het vak, de kleur en de lettergrootte.

En bovendien was mijn code veel minder geoptimaliseerd.

Voor de kleur die niet goed is, doe ik een verzoek aan de hotline en ik zal zien waarom het niet werkt, want het is duidelijk ergens een optie, aangezien het handmatig zonder de macro niet beter werkt.

Hier is de definitieve code zonder de foutafhandeling die niet per se nuttig is sinds de integratie (alleen op een 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

Hartelijk dank

 

 

2 likes
9

Hallo

Voor de kleur, zorg ervoor dat je de checkbox knop niet hebt in de werkbalk "Lijnopmaak", zie HIER.

Vriendelijke groeten

1 like
10

Nee, het is niet geactiveerd, blijkbaar zou het meer komen door het instellen van de kleur van de lijn die niet standaard is (vakje niet aangevinkt) en plotseling wordt het grijs.

Ter bevestiging, want ik had geen tijd om dieper te graven dan dat.

Hoe dan ook, de kleur is minder belangrijk dan de rest, dus ik valideer je meest relevante antwoord.

 

11

Hallo

Ik heb hetzelfde probleem voor kleuren als sbadenis, heb je het probleem opgelost?

12

Dit probleem is niet opgelost.

Ik moest het bedrijf starten zonder de kleur vanwege tijdgebrek en sindsdien heb ik het probleem niet meer kunnen onderzoeken.

Het probleem komt niet van de macro, omdat ik deze met de mano kan reproduceren.

Als ik mijn annotatie typ, is de rode laag rood en zodra ik deze valideer, wordt deze grijs...

Aan de andere kant, als je de oplossing vindt, ben ik geïnteresseerd.