21 mars 2014
Lier une ligne de repère à un nom de bloc
Cette macro permet de noter le nom d'un bloc sélectionné à l'aide d'une ligne de repère. En adaptant le code on pourrait extraire la valeur d'un attribut ou extraire la longueur d'une spline ou une aire quelconque.
'Cette macro permet de noter dans une ligne de repère le nom du bloc sélectionné
Sub NoterNomBloc()
Dim Pt As Variant, Pp As Variant, Pp1 As Variant
Dim Entite As AcadEntity
Dim NomBloc As String
Dim Points(0 To 5) As Double
Dim Echelle As Double
Dim F1 As Integer, F2 As Integer
Dim i As Long
Dim Calque As String, NomStyle As String
Dim oML As AcadMLeader
On Error GoTo Err_NoterNomBloc
'Initialisation des variables :
Echelle = 1 'Echelle de la "Leaderline" (A régler en fonction de l'échelle du dessin)
Calque = "0" 'Nom du calque où sera inséré le repère (Attention ! il faut qu'il soit présent dans le dessin !)
NomStyle = "Standard" 'Nom du style de la leaderline
'Fonctionnement de la macro en boucle
'Taper pour quitter
Do
'Sélection du bloc :
Do
ThisDrawing.Utility.GetEntity Entite, Pt, "Sélectionner le bloc"
If Entite.ObjectName = "AcDbBlockReference" Then Exit Do
MsgBox "L'objet cliqué n'est pas un bloc !", vbExclamation, "Erreur de sélection !"
Loop
'Extraire le nom du bloc :
NomBloc = Entite.Name
'Insérer une ligne repère
'Sélection des points d'insertion :
Pp = ThisDrawing.Utility.GetPoint(, "Saisir emplacement")
Pp1 = ThisDrawing.Utility.GetPoint(Pp, "Saisir position")
'La position de la leaderline n'est pas très évoluée, je la repositionne plus finement après.
If Pp(0) > Pp1(0) Then
F1 = -1
Else
F1 = 1
End If
If Pp(1) > Pp1(1) Then
F2 = -1
Else
F2 = 1
End If
Points(0) = Pp(0): Points(1) = Pp(1): Points(2) = 0
Points(3) = Pp(0) + 50 * F1: Points(4) = Pp(1) + 50 * F2: Points(5) = 0
'Insertion du repère dans le dessin :
Set oML = ThisDrawing.ModelSpace.AddMLeader(Points, i)
'Ajout du nom du bloc "En dur" dans le repère :
oML.TextString = NomBloc
'On place le repère dans le bon calque
oML.Layer = Calque
'avec le bon style
oML.StyleName = NomStyle
'et à la bonne échelle
oML.ScaleFactor = Echelle
Loop
'Gestion des erreurs
Err_NoterNomBloc:
If Err.Number <> -2147352567 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") dans la procédure NoterNomBloc."
End If
End Sub
Coloration syntaxique vb/vba/vb.net
Sub NoterNomBloc()
Dim Pt As Variant, Pp As Variant, Pp1 As Variant
Dim Entite As AcadEntity
Dim NomBloc As String
Dim Points(0 To 5) As Double
Dim Echelle As Double
Dim F1 As Integer, F2 As Integer
Dim i As Long
Dim Calque As String, NomStyle As String
Dim oML As AcadMLeader
On Error GoTo Err_NoterNomBloc
'Initialisation des variables :
Echelle = 1 'Echelle de la "Leaderline" (A régler en fonction de l'échelle du dessin)
Calque = "0" 'Nom du calque où sera inséré le repère (Attention ! il faut qu'il soit présent dans le dessin !)
NomStyle = "Standard" 'Nom du style de la leaderline
'Fonctionnement de la macro en boucle
'Taper pour quitter
Do
'Sélection du bloc :
Do
ThisDrawing.Utility.GetEntity Entite, Pt, "Sélectionner le bloc"
If Entite.ObjectName = "AcDbBlockReference" Then Exit Do
MsgBox "L'objet cliqué n'est pas un bloc !", vbExclamation, "Erreur de sélection !"
Loop
'Extraire le nom du bloc :
NomBloc = Entite.Name
'Insérer une ligne repère
'Sélection des points d'insertion :
Pp = ThisDrawing.Utility.GetPoint(, "Saisir emplacement")
Pp1 = ThisDrawing.Utility.GetPoint(Pp, "Saisir position")
'La position de la leaderline n'est pas très évoluée, je la repositionne plus finement après.
If Pp(0) > Pp1(0) Then
F1 = -1
Else
F1 = 1
End If
If Pp(1) > Pp1(1) Then
F2 = -1
Else
F2 = 1
End If
Points(0) = Pp(0): Points(1) = Pp(1): Points(2) = 0
Points(3) = Pp(0) + 50 * F1: Points(4) = Pp(1) + 50 * F2: Points(5) = 0
'Insertion du repère dans le dessin :
Set oML = ThisDrawing.ModelSpace.AddMLeader(Points, i)
'Ajout du nom du bloc "En dur" dans le repère :
oML.TextString = NomBloc
'On place le repère dans le bon calque
oML.Layer = Calque
'avec le bon style
oML.StyleName = NomStyle
'et à la bonne échelle
oML.ScaleFactor = Echelle
Loop
'Gestion des erreurs
Err_NoterNomBloc:
If Err.Number <> -2147352567 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") dans la procédure NoterNomBloc."
End If
End Sub
Coloration syntaxique vb/vba/vb.net
Publicité
Publicité
Commentaires