Mise en plan note par macro

Bob_2000 · Décembre 10, 2025, 10:24

je ne dois pas être très doué mais je n’arrives pas à positionner ma note au point, malgré le fait que mes x et y soient correctes quand je fait F8 je vois que c’est bon il doit y avoir un pb avec Set insPt = swMathUtil.CreatePoint(vInsertPoint) puisque l’insertion de mon bloc est toujours au point 0,0

Sub Notes_01()
Dim swApp As Object
Dim Part As Object
Dim myBlockDefinition As Object
Dim myAnnotation As Object
Dim URL As String
Dim NR As String
Dim NUM As String 'Pas byte sinon bt annulé impossible
Dim REPONSE As String

Dim swMathUtil As Object
Dim insPt As Object
Dim vInsertPoint(2) As Double

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc

Dim X_Coord_Val As Double
Dim Y_Coord_Val As Double
X_Coord_Val = CDbl(UserForm2.TextBox1.Value)
Y_Coord_Val = CDbl(UserForm2.TextBox2.Value)
Z_Coord_Val = 0#

URL = "C:\Notes\"

NUM = InputBox("1 : Tableau découpe insert hexagonal" & vbCrLf & _
               "2 : Gousset" & vbCrLf & _
               "3 : Soudure" & vbCrLf & vbCrLf & _
               "Entrez le numéro du bloc à insérer", "Choix de la note")

Select Case NUM
    Case "1": NR = "Découpe_insert_hex.SLDBLK": Echelle = 1: EXT = "A"
    Case "2": NR = "Gousset.sldnotestl": EXT = "B"
    Case "3": NR = "Soudure.SLDBLK": Echelle = 0.045: EXT = "A"
    Case Else: Exit Sub
End Select

REPONSE = URL & NR

If EXT = "B" Then
Set myAnnotation = Part.Extension.InsertAnnotationFavorite(REPONSE, X_Coord_Val, Y_Coord_Val, 0)
Else
'Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(Nothing, REPONSE, False, Echelle, 0)
Set swMathUtil = swApp.GetMathUtility

vInsertPoint(0) = X_Coord_Val
vInsertPoint(1) = Y_Coord_Val
vInsertPoint(2) = Z_Coord_Val


Set insPt = swMathUtil.CreatePoint(vInsertPoint)
Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(insPt, REPONSE, False, Echelle, 0)
End If

End Sub

d_roger · Décembre 10, 2025, 10:45

Bonjour,

Voici un petit exemple qui fonctionne chez moi :

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.ModelView
Dim TheMouse As SldWorks.mouse
Dim obj As New Classe1

Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swModelView = swModel.GetFirstModelView
    Set TheMouse = swModelView.GetMouse

    obj.init TheMouse, swApp, swModel
    
    swApp.SendMsgToUser "Veuillez définir la position de la note."
End Sub

Et pour la classe :

'Classe1
Dim WithEvents ms As SldWorks.mouse

Private cSwApp As SldWorks.SldWorks
Private cswModel As SldWorks.ModelDoc2

Private Sub Class_Initialize()

End Sub

Public Sub init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
    Set ms = mouse
    Set cSwApp = sldw
    Set cswModel = slddoc
End Sub

Private Function ms_MouseSelectNotify(ByVal Ix As Long, ByVal Iy As Long, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Long
    Set myNote = cswModel.InsertNote("C'est ma note")
    If Not myNote Is Nothing Then
       Set myAnnotation = myNote.GetAnnotation()
       If Not myAnnotation Is Nothing Then
          boolstatus = myAnnotation.SetPosition(x, y, 0)
       End If
    End If
    cswModel.ClearSelection2 True
    cswModel.WindowRedraw
    
    Dim sBlockPath As String
    sBlockPath = "C:\Users\dro\Documents\Bibliotheque_blocs\Tableau.SLDBLK"
    Set swBlkInst = Insert_Block(cswModel, sBlockPath, x, y)

    End
End Function

Private Function ms_MouseLBtnDownNotify(ByVal x As Long, ByVal y As Long, ByVal WParam As Long) As Long
    
End Function

Function Insert_Block(ByVal rModel As ModelDoc2, ByVal blkName As String, ByVal Xpt As Double, ByVal Ypt As Double, Optional ByVal sAngle As Double = 0, Optional ByVal sScale As Double = 1) As Object
    Dim swBlockDef As SketchBlockDefinition
    Dim swMathPoint As MathPoint
    Dim swMathUtil As MathUtility
    
    Set swMathUtil = cSwApp.GetMathUtility

    Dim pt(2) As Double
    pt(0) = Xpt
    pt(1) = Ypt
    pt(2) = 0

    Set swMathPoint = swMathUtil.CreatePoint(pt)

    Set swBlockDef = rModel.SketchManager.MakeSketchBlockFromFile(swMathPoint, blkName, False, sScale, sAngle)

    rModel.GraphicsRedraw2
End Function

Pense à changer la ligne :
sBlockPath = « C:\Users\dro\Documents\Bibliotheque_blocs\Tableau.SLDBLK »
pour mettre le chemin de ton bloc.

Cordialement,

Bob_2000 · Décembre 10, 2025, 11:38

je ne comprends rien à cette macro, le bloc inséré est en dehors de la feuille

d_roger · Décembre 10, 2025, 12:10

Lors du lancement de la macro il y a le message :

Là il faut cliquer sur OK puis cliquer quelque part sur la feuille, une note « C’est ma note » se positionne sur le point sélectionné et le bloc choisi dans le chemin du « sBlockPath » s’insère aussi sur ce point sélectionné, bien sûr c’est le point d’origine du bloc qui est positionné sur le point sélectionné donc si ce point d’origine du bloc est mal positionné par rapport aux éléments visible du bloc alors le bloc peut se retrouver en dehors de la feuille …

Bob_2000 · Décembre 10, 2025, 12:47

le point d’insertion de mon bloc est bien proche du bloc, l’insertion ne se fait pas à la vrai position x y mais à 0,0
Animation

pourtant quand je fais F8, les points x et y indiquent bien la bonne valeur
le pb est ici
Set swMathPoint = swMathUtil.CreatePoint(pt)

Set swBlockDef = rModel.SketchManager.MakeSketchBlockFromFile(swMathPoint, blkName, False, sScale, sAngle)

il n’intègre pas bien x et y

d_roger · Décembre 10, 2025, 1:07

Difficile de résoudre le souci, chez moi ça fonctionne :

d_roger · Décembre 10, 2025, 1:18

A tout hasard, il ne reste pas des traces de blocs effacés dans l’arbre de création ?

Bob_2000 · Décembre 10, 2025, 1:21

pas de trace d’anciens blocs que j’ai supprimé avant lancement
Animation

sbadenis · Décembre 10, 2025, 1:37

Après essai, j’ai un peu le même soucis avec un bloc sous forme de tableau.
Et si je clique sur ligne d’attache et point d’insertion il y à ces 2 symboles (noir + bleu)

Possiblement l’un des 2, force une certaine position peut-être:

d_roger · Décembre 11, 2025, 3:28

Bonjour,
Est-il possible de faire des tests sur un plan à l’échelle 1:1, le seul moment ou je mets en défaut le code proposé c’est quand je suis à une autre échelle de plan.
Cordialement,

sbadenis · Décembre 11, 2025, 3:34

J’en étais arrivé à la même conclusion, problème d’échelle.
Après essai avec une échelle 1:1 et unité en mètre au lieu de mm cela fonctionne parfaitement donc simple conversion a faire + mise à l’échelle pour avoir le bon point d’insertion.

Et l’échelle du bloc est également à prendre en considération éventuellement avec l’échelle.

Bob_2000 · Décembre 11, 2025, 3:55

chez moi echelle 1/1 ca positionne toujours à zero

sbadenis · Décembre 11, 2025, 3:57

En changeant l’unité du document en mks également?
Outil/options/Propriétés du document:

Et j’ai coché pour tester cette unité MKS (au lieu du MMGS habituel)

Maclane · Décembre 11, 2025, 4:21

Cela me semble plutôt normal, les unité de bases des API Solidworks sont :
Le mètre et le radian (allez-savoir pourquoi).

Donc techniquement il faudrait : pour retrouver les coordonnées en millimètres (Échelle 1/1)

    Dim pt(2) As Double
    pt(0) = Xpt/1000
    pt(1) = Ypt/1000
    pt(2) = 0

Reste aussi à récupérer le facteur d’échelle de la feuille:

Dim sheetScale As Double
sheetScale = swModel.Extension.GetSheetScale

et donc on devrait obtenir:

Dim pt(2) As Double
pt(0) = Xpt*sheetScale/1000
pt(1) = Ypt*sheetScale/1000
pt(2) = 0

Un truc un peu comme cela quoi (je n’ai pas accès à Solidworks donc c’est une proposition à l’aveugle…)

Centor · Décembre 11, 2025, 4:46

Bonjour,

Voici une petite copie d’un code que j’ai effectuez pour l’insertion de texte sur solidworks dans une mise en plan

Sous-titre privé CommandButton2_Click()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Partie.FontPoints 13

Atténuez myNote en tant qu’objet
Atténuez myAnnotation As Object
Dim myTextFormat As Object
Set myNote = Part.InsertNote(« TECH. IDENT. : »)
Sinon, myNote n’est rien alors
myNote.LockPosition = Faux
myNote.Angle = 0
boolstatus = monNote.BallonSet(0, 0)
Définir monAnnotation = monNote.ObtenirAnnotation()
Si non, myAnnotation n’est rien alors
longstatus = monAnnotation.SetLeader3(swLeaderStyle_e.swNO_LEADER, 0, Vrai, Faux, Faux, Faux)
boolstatus = monAnnotation.SetPosition(0.099, 0.286, 0)

  Set myTextFormat = Part.GetUserPreferenceTextFormat(0)
  myTextFormat.Italic = False
  myTextFormat.Underline = False
  myTextFormat.Strikeout = False
  myTextFormat.Bold = False
  myTextFormat.Escapement = 0
  myTextFormat.LineSpacing = 0.001
  myTextFormat.CharHeightInPts = True
  myTextFormat.TypeFaceName = "Century Gothic"
  myTextFormat.WidthFactor = 1
  myTextFormat.ObliqueAngle = 0
  myTextFormat.LineLength = 0
  myTextFormat.Vertical = False
  myTextFormat.BackWards = False
  myTextFormat.UpsideDown = False
  myTextFormat.CharSpacingFactor = 1
  boolstatus = myAnnotation.SetTextFormat(0, False, myTextFormat)

Fin si
Fin si
Partie.ClearSelection2 Vrai
Partie.FenêtreRedessiner

Fin du Remplaçant

Bonne soirée

d_roger · Décembre 11, 2025, 5:00

Pour l’insertion d’un bloc :

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.ModelView
Dim TheMouse As SldWorks.mouse
Dim obj As New Classe1

Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swModelView = swModel.GetFirstModelView
    Set TheMouse = swModelView.GetMouse

    obj.init TheMouse, swApp, swModel
    
    swApp.SendMsgToUser "Veuillez définir la position du bloc."
End Sub

Et pour la classe :

'Classe1
Dim WithEvents ms As SldWorks.mouse

Private cSwApp As SldWorks.SldWorks
Private cswModel As SldWorks.ModelDoc2
Private cswModelView As SldWorks.ModelView
Private cswDraw As SldWorks.DrawingDoc
Private cswSheet As SldWorks.Sheet
Private cswView As SldWorks.View
Private ech As Variant
Private cScale As Variant

Private Sub Class_Initialize()

End Sub

Public Sub init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
    Set ms = mouse
    Set cSwApp = sldw
    Set cswModel = slddoc
    Set cswDraw = cswModel
    Set cswSheet = cswDraw.GetCurrentSheet
    Set cswView = cswDraw.GetFirstView
End Sub

Private Function ms_MouseSelectNotify(ByVal Ix As Long, ByVal Iy As Long, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Long
    ech = cswView.ScaleRatio
    cScale = ech(0) / ech(1)

    Dim sBlockPath As String
    sBlockPath = "C:\Users\dro\Documents DRO-P10\SW local\Bibliotheque_Annotations et blocs\Tableau engrenage.SLDBLK"
    Set swBlkInst = Insert_Block(cswModel, sBlockPath, x / cScale, y / cScale)
    
    End
End Function

Private Function ms_MouseLBtnDownNotify(ByVal x As Long, ByVal y As Long, ByVal WParam As Long) As Long
    
End Function

Function Insert_Block(ByVal rModel As ModelDoc2, ByVal blkName As String, ByVal Xpt As Double, ByVal Ypt As Double, Optional ByVal sAngle As Double = 0, Optional ByVal sScale As Double = 1) As Object
    Dim swBlockDef As SketchBlockDefinition
    Dim swMathPoint As MathPoint
    Dim swMathUtil As MathUtility
    
    Set swMathUtil = cSwApp.GetMathUtility
    
    Dim pt(2) As Double
    pt(0) = Xpt
    pt(1) = Ypt
    pt(2) = 0

    Set swMathPoint = swMathUtil.CreatePoint(pt)

    Set swBlockDef = rModel.SketchManager.MakeSketchBlockFromFile(swMathPoint, blkName, False, sScale, sAngle)

    rModel.GraphicsRedraw2
End Function

sbadenis · Décembre 12, 2025, 6:35

@d_roger macro, parfaitement fonctionnelle pour moi , avec un code très propre et lisible comme à ton habitude!
@Bob_2000 à toi de valider si cela fonctionne également pour toi.
@Centor ta macro c’est transformée, il faut l’éditer dans une fenêtre spécial (texte préformaté), sinon la conversion linguistique fait de l’humour:

Pour rigoler :

Par contre la fin du sous-marin à disparu, pour faire place à la fin du remplaçant!

Centor · Décembre 12, 2025, 6:58

mdr oui effectivement je viens de remarquer xD

Private Sub CommandButton2_Click()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Part.FontPoints 13

Dim myNote As Object
Dim myAnnotation As Object
Dim myTextFormat As Object
Set myNote = Part.InsertNote("<FONT size=13PTS>TECH. IDENT.:")
If Not myNote Is Nothing Then
   myNote.LockPosition = False
   myNote.Angle = 0
   boolstatus = myNote.SetBalloon(0, 0)
   Set myAnnotation = myNote.GetAnnotation()
   If Not myAnnotation Is Nothing Then
      longstatus = myAnnotation.SetLeader3(swLeaderStyle_e.swNO_LEADER, 0, True, False, False, False)
      boolstatus = myAnnotation.SetPosition(0.099, 0.286, 0)

      Set myTextFormat = Part.GetUserPreferenceTextFormat(0)
      myTextFormat.Italic = False
      myTextFormat.Underline = False
      myTextFormat.Strikeout = False
      myTextFormat.Bold = False
      myTextFormat.Escapement = 0
      myTextFormat.LineSpacing = 0.001
      myTextFormat.CharHeightInPts = True
      myTextFormat.TypeFaceName = "Century Gothic"
      myTextFormat.WidthFactor = 1
      myTextFormat.ObliqueAngle = 0
      myTextFormat.LineLength = 0
      myTextFormat.Vertical = False
      myTextFormat.BackWards = False
      myTextFormat.UpsideDown = False
      myTextFormat.CharSpacingFactor = 1
      boolstatus = myAnnotation.SetTextFormat(0, False, myTextFormat)
   End If
End If
Part.ClearSelection2 True
Part.WindowRedraw

End Sub

Private Sub CommandButton3_Click()
Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Part.FontPoints 13

Dim myNote As Object
Dim myAnnotation As Object
Dim myTextFormat As Object
Set myNote = Part.InsertNote("<FONT size=13PTS>{Identification}")
If Not myNote Is Nothing Then
   myNote.LockPosition = False
   myNote.Angle = 0
   boolstatus = myNote.SetBalloon(0, 0)
   Set myAnnotation = myNote.GetAnnotation()
   If Not myAnnotation Is Nothing Then
      longstatus = myAnnotation.SetLeader3(swLeaderStyle_e.swNO_LEADER, 0, True, False, False, False)
      boolstatus = myAnnotation.SetPosition(0.130806397772014, 0.286, 0)

      Set myTextFormat = Part.GetUserPreferenceTextFormat(0)
      myTextFormat.Italic = False
      myTextFormat.Underline = False
      myTextFormat.Strikeout = False
      myTextFormat.Bold = False
      myTextFormat.Escapement = 0
      myTextFormat.LineSpacing = 0.001
      myTextFormat.CharHeightInPts = True
      myTextFormat.TypeFaceName = "Century Gothic"
      myTextFormat.WidthFactor = 1
      myTextFormat.ObliqueAngle = 0
      myTextFormat.LineLength = 0
      myTextFormat.Vertical = False
      myTextFormat.BackWards = False
      myTextFormat.UpsideDown = False
      myTextFormat.CharSpacingFactor = 1
      boolstatus = myAnnotation.SetTextFormat(0, False, myTextFormat)
   End If
End If
Part.ClearSelection2 True
Part.WindowRedraw

End Sub

Bob_2000 · Décembre 12, 2025, 8:43

la macro de D roger fonctionne mais moi je suis toujours dans les choux, ca me place à 0,0 malgré un x et y different

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.ModelView
Dim TheMouse As SldWorks.mouse
Public obj As New Classe1
Public X_Value As Double
Public Y_Value As Double
Public Z_Value As Double
'Public cScale As Double
'Public ech As Variant

Sub Notes_00()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelView = swModel.GetFirstModelView
Set TheMouse = swModelView.GetMouse

obj.init TheMouse, swApp, swModel

UserForm2.Show vbModeless
End Sub

Sub Notes_01()
Dim swApp As Object
Dim Part As Object
Dim myBlockDefinition As Object
Dim myAnnotation As Object
Dim URL As String
Dim NR As String
Dim NUM As String 'Pas byte sinon bt annulé impossible
Dim REPONSE As String

Dim swMathUtil As Object
Dim insPt As Object
Dim vInsertPoint(2) As Double

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc


URL = "C:\Users\Notes\"

NUM = InputBox("1 : Tableau découpe insert hexagonal" & vbCrLf & _
               "2 : Gousset" & vbCrLf & _
               "3 : Soudure" & vbCrLf & vbCrLf & _
               "Entrez le numéro du bloc à insérer", "Choix de la note")

Select Case NUM
    Case "1": NR = "Découpe_insert_hex.SLDBLK": Echelle = 1: EXT = "A"
    Case "2": NR = "Gousset.sldnotestl": EXT = "B"
    Case "3": NR = "Soudure.SLDBLK": Echelle = 0.045: EXT = "A"
    Case Else: Exit Sub
End Select

REPONSE = URL & NR

If EXT = "B" Then
Set myAnnotation = Part.Extension.InsertAnnotationFavorite(REPONSE, X_Value, Y_Value, 0)
Else
Set swMathUtil = swApp.GetMathUtility

vInsertPoint(0) = X_Value
vInsertPoint(1) = Y_Value
vInsertPoint(2) = Z_Value


Set insPt = swMathUtil.CreatePoint(vInsertPoint)
Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(insPt, REPONSE, False, Echelle, 0)
End If

End Sub

Dim WithEvents ms As SldWorks.mouse
Private cSwApp As SldWorks.SldWorks
Private cswModelView As SldWorks.ModelView
Private cswModel As SldWorks.ModelDoc2
Private cswDraw As SldWorks.DrawingDoc
Private cswSheet As SldWorks.Sheet
Private cswView As SldWorks.View
Public ech As Variant
Public cScale As Double

Public Sub init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
Set ms = mouse
Set cSwApp = sldw
Set cswModel = slddoc
Set cswDraw = cswModel
Set cswSheet = cswDraw.GetCurrentSheet
Set cswView = cswDraw.GetFirstView
'If cswView Is Nothing Then Set cswView = cswDraw.GetFirstView

End Sub
Private Function ms_MouseSelectNotify(ByVal Ix As Long, ByVal Iy As Long, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Long
ech = cswView.ScaleRatio
cScale = ech(0) / ech(1)

UserForm2.TextBox1.Value = Round(x/ cScale, 4)
UserForm2.TextBox2.Value = Round(y/ cScale, 4)

End Function

Public Sub Terminer()
Set ms = Nothing
Set cSwApp = Nothing
Set cswModel = Nothing
End Sub

Private Sub CommandButton1_Click()
'OK

If TextBox1.Value = "" Or TextBox2.Value = "" Then Exit Sub
X_Value = CDbl(Me.TextBox1.Value)
Y_Value = CDbl(Me.TextBox2.Value) 
Z_Value = 0#
    
obj.Terminer
Set obj = Nothing
Unload UserForm2
Set UserForm2 = Nothing

Notes_01
End Sub

Maclane · Décembre 12, 2025, 8:48

@d_roger :
Tu as aussi prévu un « event » sur le clic Gauche ?

Private Function ms_MouseLBtnDownNotify(ByVal x As Long, ByVal y As Long, ByVal WParam As Long) As Long
End Function