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

Faire la liste des calques dans l'espace objet

Partager cet article