Faire la liste des calques dans l'espace objet
Aujourd'hui, je vous propose un petit code "clé en main" qui fait la liste des calques et la place dans l'espace objet. Chaque ligne de texte définissant le nom de calque, ainsi que ses propriétés type de ligne, épaisseur de trait et couleur est placé dans son calque respectif.
Il peut être ainsi facile d'imprimer cette liste de calque par exemple.
Comme tous les autres codes de ce site, il a été testé sous ACAD2005 et Windows XP. A copier dans un module.
'-------------------------------------------------------------------
'Cette macro liste les calques présents dans le dessin en écrivant
'leur nom, type de trait, épaisseur de trait et couleur dans
'l'espace objet. Chaque ligne sera rangée sur son calque respectif
'Auparavant, la macro demandera de saisir l'emplacement de la liste
'à l'écran.
'-------------------------------------------------------------------
'V.1 14/09/2011 - AutoCAD et VBA - http://autocadvba.canalblog.com/
'-------------------------------------------------------------------
Sub ListerCalques()
'Liste des variables
Dim Calque As AcadLayer
Dim objTxt As AcadText
Dim interligne As Double
Dim htTexte As Double
Dim NomCalque As String
Dim TypeLigne As String
Dim EpLigne As String
Dim Couleur As String
Dim Texte As String
Dim PtIns As Variant
On Error GoTo ListerCalques_Error
'Initialisation de la macro
'Trouve la hauteur de texte du style courant
htTexte = ThisDrawing.ActiveTextStyle.Height
'Si la hauteur=0, alors choisir la hauteur 2
If htTexte = 0 Then htTexte = 2.5
'Valeur de l'interligne
interligne = 1.5
'Demande de l'emplacement de la liste
PtIns = ThisDrawing.Utility.GetPoint(, "Saisir l'emplacement de la liste")
'Parcours de la liste des calques présents dans le dessin
For Each Calque In ThisDrawing.Layers
With Calque
'Détermination du nom du calque
NomCalque = .Name
'Détermination du nom de type de ligne
TypeLigne = .Linetype
'Détermination de l'épaisseur de la ligne
If .Lineweight = -3 Then '-3 est le code pour les lignes Ep Par défaut
EpLigne = "Par défaut"
Else 'Sinon, le code de l'épaisseur est donné en 100e
'Il faut le convertir pour trouver des millimètres
'et le formater pour obtenir 2 chiffres après la virgule
EpLigne = Format(CStr(.Lineweight / 100), "0.00")
End If
Select Case .color 'Détermination de la couleur
'ACAD possède 6 variables définissant les couleurs de base
'On traduit les variables en français.
Case acWhite: Couleur = "Blanc"
Case acYellow: Couleur = "Jaune"
Case acGreen: Couleur = "Vert"
Case acRed: Couleur = "Rouge"
Case acCyan: Couleur = "Cyan"
Case acBlue: Couleur = "Bleu"
Case acMagenta: Couleur = "Magenta"
'Les autres couleurs, on indique leur numéro
Case Else: Couleur = "N°" & CStr(.color)
End Select
'Comosition de la ligne. Chaque paramètre est séparé par --
Texte = NomCalque & " -- " & TypeLigne & " -- " & EpLigne & " -- " & Couleur
'Insertion du texte dans l'espace objet
Set objTxt = ThisDrawing.ModelSpace.AddText(Texte, PtIns, htTexte)
objTxt.Layer = .Name 'On place le texte créé dans son calque
objTxt.color = acByLayer 'On règle la couleur le texte sur Par calque
objTxt.Linetype = "BYLAYER" 'On règle le type de trait du texte sur Par calque
objTxt.Lineweight = acLnWtByLayer 'On règle l'épaisseur du texte sur Par calque
'On modifie la valeur y du point d'insertion en la soustrayant de
'la hauteur du texte courant x interligne choisie.
PtIns(1) = PtIns(1) - htTexte * interligne
End With
Next 'Traitement du calque suivant
'Fin de la macro
On Error GoTo 0
Exit Sub
'Gestionnaire d'erreur :
ListerCalques_Error:
If Err.Number = -2147352567 Or Err.Number = -2145320928 Then
'Si la touche échap ou le clic droit de la liste est pressé
'quand le point d'insertion est demandé, on quitte la macro.
Exit Sub
Else 'Sinon, donner un message d'erreur.
MsgBox "Une erreur s'est produite", , "Liste des calques"
End If
End Sub
Coloration syntaxique vb/vba/vb.net