Bonjour,
Après l'ouverture d'un plan, je souhaiterais réalisé plusieurs étapes suivantes:
1- Vérifier le format du plan (A4H, A3H...)
2-Suivant le format de la feuille ajouter une annotation (avec texte en rouge et case rectangulaire autour) avec des coordonnées différentes suivant le format
3-Boucler sur la feuille suivante.
Pour l'instant j'arrive à créer la note dans une feuille mais en noir sans case et sans cadre rectangulaire autour et je souhaiterais donc de l'aide pour cette 1ère modification:
A-) Modifier le texte en rouge et case rectangulaire autour
B-)Un exemple ou les fonction à utiliser pour lancer mon code suivant le format de la feuille
C-) un exemple qui boucle sur plusieurs feuilles
Avec ses différents éléments j'espère enfin pouvoir réalisé cette macro malgré mon niveau débutant en VBA.
Mon code très simpliste à ce jour:
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
Merci d'avance pour toutes les contributions qui m'aideront à avancer sur ce sujet.
Je me répond tout seul pour la boucle:
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
Reste encore le format à vérifier et la mise en forme de la note (couleur + case)
Pour la couleur, il me semble qu'il faut mettre l'objet dans un calque spécifique (en tout cas, c'est ce que j'ai fait quand j'en eu besoin).
Quand j'ai besoin de faire une macro, souvent je passe par l'enregistreur, ça permet de récupérer facilement des bouts de code sur les opérations de base Par exemple pour créer la case autour du texte, si la case fait partie de l'annotation (rubrique contour).
stefbeno J'ai essayé l'enregistreur pour créer une note avec Texte + couleur + cadre et résultat: une macro vide...
A moins que mon enregistreur déconne cela n'a malheureusement pas été très probant...
Mais merci quand même pour le conseil.
Bonjour,
Tu dois pouvoir t'aider du code ci-dessous pour faire ce que tu souhaites (attention, je ne me suis pas occupé de la gestion des erreurs), je ne change que la position du texte suivant le format mais tu peux aussi changer le texte, pour cela tu définis une variable string que tu rempli avec le texte voulu dans chaque "Case" puis tu transfert cette variable dans la fonction "insertionNote" à la place du texte en dur. Je n'ai pas commenté le code mais je sais que tu vas savoir le lire.
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
Cordialement,
2 « J'aime »
Merci d.roger une fois de plus!
J'arrive à la fin de cette macro mais il reste 2 petits soucis à régler:
- je souhaite grossir la police de texte de la note, et je ne trouve rien dans l'aide permettant de grossir cette note (http://help.solidworks.com/2018/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.inote_members.html).
A moins que je passe à côté...
- Enfin pour la couleur cela ne fonctionne pas. il me créer bien le calque avec la couleur mais l'annotation prends la couleurs gris...
Et en mode création annotation manuel, dans le bon calque (rouge) l'annotation est rouge mais passe en gris à la validation. Je pense que cela vient plus d'une option SW mais je ne trouve pas laquelle.
Sinon la macro fonctionne parfaitement et j'ai réussi à en comprendre la grande majorité et même à la modifier avec suppression des "case" j'ai juste appliquer une soustraction de la position X et Y par rapport à la taille de la feuille ce qui me place l'annotation en haut à gauche de chaque feuille comme je le voulais et plus simplement.
Bonjour,
Pour la taille de police de la note tu peux remplacer le Sub insertionNote par celui-ci :
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
Cela permet de mettre une taille de texte (ici 0.02 m) et aussi de mettre en italique et en gras si tu veux, d'autres options ICI.
Pour la couleur, cela vient effectivement probablement d'une option de SW mais je n'ai pas réussi à trouver laquelle pour le moment, sur mon PC la couleur reste bien en rouge...
Cordialement,
1 « J'aime »
Merci beaucoup d.roger pour ton aide précieuse sur le sujet.
J'en étais arrivé à insérer le texte de mon côté avec les coordonnées désiré mais sans la case, la couleur et la dimension de police.
Et de plus mon code était beaucoup moins optimisé.
Pour la couleur qui n'est pas bonne je fais une demande auprès de la hotline et je verrais pourquoi cela ne fonctionne pas car il s'agit clairement d'une option quelque part puisque manuellement sans la macro cela ne fonctionne pas mieux.
Voici le code finale sans la gestion des erreures qui n'est pas forcément utile puisque lancé depuis intégration (sur une MEP uniquement)
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
Merci beaucoup
2 « J'aime »
Bonjour,
Pour la couleur, vérifie que tu n'aie pas le bouton 
de cocher dans la barre d'outils "Format de ligne", voir ICI.
Cordialement,
1 « J'aime »
Non elle n'est pas activé, apparemment cela viendrait plus de définir la couleur de la ligne qui n'est pas sur Par défaut (case non coché ) et du coup il prends du gris.
A confirmer, car je n'ai pas eu le temps de creuser plus que ça.
Quoi qu'il en soit la couleur est moins importante que le reste je valide donc ta réponse la plus pertinente.
Bonjour,
J'ai le même problème pour les couleurs que sbadenis, as tu résoluts le problème?
Non pas résolu ce soucis.
J'ai du lancé l'affaire sans la couleur faute de temps et depuis je n'ai pas réussi à me pencher sur le problème.
Le souci ne vient pas de la macro puisque j'arrive à le reproduire à la mano.
Quand je tape mon annotation dans le calque rouge est est rouge et dès que je la valide elle passe en gris...
Par contre si tu trouve poste moi la solution, je suis preneur.