Hello
After opening a plan, I would like to carry out several of the following steps:
1- Check the format of the plan (A4H, A3H...)
2-Depending on the format of the sheet, add an annotation (with text in red and rectangular box around it) with different coordinates depending on the format
3-Loop on the next sheet.
For the moment I manage to create the note in a sheet but in black without a box and without a rectangular frame around it and I would therefore like help for this 1st modification:
A-) Change the text to red and rectangular box around it
B-)An example or the functions to use to launch my code according to the format of the sheet
C-) an example that loops over several sheets
With its different elements I hope to finally be able to achieve this macro despite my beginner level in VBA.
My very simplistic code to date:
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
Thank you in advance for all the contributions that will help me move forward on this subject.
I answer myself for the loop:
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
There is still the format to check and the formatting of the note (color + box)
For the color, it seems to me that you have to put the object in a specific layer (at least, that's what I did when I needed it).
When I need to make a macro, I often go through the recorder, it allows me to easily retrieve bits of code on the basic operations For example to create the box around the text, if the box is part of the annotation (outline section).
stefbeno I tried the recorder to create a note with Text + color + frame and result: an empty macro...
Unless my recorder messed up, it was unfortunately not very convincing...
But thank you anyway for the advice.
Hello
You should be able to use the code below to do what you want (be careful, I didn't take care of the error handling), I only change the position of the text according to the format but you can also change the text, for this you define a string variable that you fill with the desired text in each "Case" then you transfer this variable to the "insertionNote" function instead of hard-coded text. I haven't commented on the code but I know you'll know how to read it.
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
Kind regards
2 Likes
Thank you d.roger once again!
I'm coming to the end of this macro but there are still 2 small problems to fix:
- I want to enlarge the text font of the note, and I can't find anything in the help to enlarge this note (http://help.solidworks.com/2018/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.inote_members.html).
Unless I miss it...
- Finally for the color it doesn't work. He creates the layer with the color but the annotation takes the gray colors...
And in manual annotation creation mode, in the correct layer (red) the annotation is red but changes to gray on validation. I think it comes more from a SW option but I can't find which one.
Otherwise the macro works perfectly and I managed to understand the vast majority of it and even to modify it with the removal of the "boxes", I just applied a subtraction of the X and Y position in relation to the size of the sheet which places the annotation at the top left of each sheet as I wanted and more simply.
Hello
For the font size of the note, you can replace the Sub insertionNote with this one:
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
This allows you to put a text size (here 0.02 m) and also to put in italics and bold if you want, other options HERE.
For the color, it probably comes from a SW option but I haven't been able to find which one for the moment, on my PC the color remains in red...
Kind regards
1 Like
Thank you very much d.roger for your precious help on the subject.
I had ended up inserting the text on my side with the desired coordinates but without the box, the color and the font size.
And moreover my code was much less optimized.
For the color that is not good, I make a request to the hotline and I will see why it doesn't work because it is clearly an option somewhere, since manually without the macro it does not work better.
Here is the final code without the error handling which is not necessarily useful since it was launched from integration (on an MEP only)
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
Thank you very much
2 Likes
Hello
For the color, make sure you don't have the checkbox button 
in the "Line format" toolbar, see HERE.
Kind regards
1 Like
No it is not activated, apparently it would come more from setting the color of the line which is not to Default (box not checked) and suddenly it takes gray.
To be confirmed, because I didn't have time to dig deeper than that.
Anyway, the color is less important than the rest, so I validate your most relevant answer.
Hello
I have the same problem for colors as sbadenis, have you solved the problem?
Not solved this problem.
I had to start the business without the color due to lack of time and since then I haven't been able to look into the problem.
The problem doesn't come from the macro since I can reproduce it with the mano.
When I type my annotation in the red layer is red and as soon as I validate it it turns gray...
On the other hand, if you find the solution, I'm interested.