Un des principaux avantages de VBA par rapport à AutoLISP est la facilité de communication avec les applications OLE. Alors que c'est particulièrement ardu en AutoLISP, vous découvrirez à l'aide de l'exemple qui suit, que c'est un jeu d'enfant d'envoyer des informations vers Excel.
Ce programme devrait vous être très utile, à condition de l'adapter à vos besoins réels.
Le programme incorpore des fonctions de tri des feuilles de résultats.

• La première feuille affichera la liste des blocs avec tous leurs attributs.
  Une fonction qui sera particulièrement utile pour la gestion des dessins.
  Pédagogiquement plus qu'utilement, la feuille donne également le calque sur lequel le bloc est inséré, l'échelle du bloc et les coordonnées du point d'insertion.
• La seconde feuille concerne la liste des calques avec la couleur et le type de lignes associés, ainsi que leurs propriétés.
• La troisième feuille énumère les styles de texte avec leurs caractéristiques.
• La dernière feuille liste les types de ligne avec leur description.

• On conserve le nom UserForm1
• Modifiez la propriété Caption par Description du dessin en cours

• Option Explicit oblige à déclarer les variables, ce qui permet de réduire les conséquences des fautes de frappe.
• Public : les valeurs de ces variables sont utilisées dans plusieurs procédures.

    Option Explicit
    'Initialisation des variables
    Public AppExcel As Object          ' Variable objet Application Excel
    Public FichExcel As String         ' Nom du fichier avec le chemin
 
Public Sub Descript()
    On Error Resume Next
    ' on récupère le nom du dessin
    FichExcel = ThisDrawing.FullName
    If FichExcel <> "" Then         ' Pour être sûr que ce n'est pas un dessin sans nom
      FichExcel = Left$(FichExcel, Len(FichExcel) - 3) ' on retire l'extension dwg à la fin du nom
      FichExcel = FichExcel + "xls"     ' on ajoute l'extension pour Excel
     Else
      FichExcel = "sansnom.xls"     ' c'est un dessin sans nom !
    End If
        
    UserForm1.Show
    
End Sub
    

Quand on clique sur le bouton Créer les listes :
• Chargement d'Excel s'il n'est pas déjà en cours.
• Création d'un nouveau classeur.
• Lancement des routines d'élaboration des feuilles.
• Sauvegarde des feuilles
• Fermeture d'Excel - Peut être désactivée pour laisser Excel ouvert.

Private Sub cmdAction_Click()
    
    ' Si erreur, continue instruction suivante
    On Error Resume Next
    ' Si Excel est déjà chargé
    Set AppExcel = GetObject(, "Excel.Application")
    ' Sinon il y a une erreur
    If Err <> 0 Then
        Err.Clear
        ' Alors lance Excel
        Set AppExcel = CreateObject("Excel.Application")
        If Err <> 0 Then
        ' si nouvelle erreur
            MsgBox "Excel ne peut se charger.", vbExclamation
            End
        End If
    End If
    'Desactivation du gestionnaire d'erreur
    On Error GoTo 0
    ' La feuille Excel est affichée
    AppExcel.Visible = True
    ' Ouvre un nouveau classeur
    AppExcel.Workbooks.Add
    
    ' Vers Procédure d'élaboration de la liste des blocs
    If chkBlocs = True Then
        ListBlocs
    End If
    ' Vers Procédure d'élaboration de la liste des calques
    If chkCalques = True Then
        ListCalques
    End If
    ' Vers Procédure d'élaboration de la liste des types de lignes
    If chkTypLignes = True Then
        ListTypLignes
    End If
    ' Vers Procédure d'élaboration de la liste des styles de texte
    If chkStyleText = True Then
        ListStyleText
    End If
    ' Tout est fini !
    ' Sauvegarde du fichier Excel
    AppExcel.ActiveWorkbook.SaveAs FichExcel
    ' Fermeture de la feuille
    AppExcel.ActiveWorkbook.Close
    ' Fermeture de l'application Excel
    AppExcel.Quit
    Unload Me

End Sub

• Activation de Feuil1
• Formattage 1ère ligne titre
• Ecriture de la liste
• Tri de la liste
• Justification de colonnes

Private Sub ListBlocs()
    ' Procédure d'élaboration de la liste des blocs
    Dim objElem As Object           ' objet Elément du dessin
    Dim objFeuille As Object        ' objet Feuille Excel
    Dim tablAttrib As Variant       ' tableau des attributs
    Dim Cpt1, RangNum As Integer    ' compteurs
    Dim PtInsert As Variant         ' point d'insertion du bloc
    Dim CellFin As String           ' Dernière cellule utilisée
    
    ' si Excel en version US, remplacez Feuil1 par Sheet1
    AppExcel.Sheets("Feuil1").Select
    ' on travaille avec Feuil1
    Set objFeuille = AppExcel.ActiveWorkbook.Sheets("Feuil1")
    ' la 1ère rangée en gras
    objFeuille.Rows("1").Font.Bold = True
    ' la 1ère colonne en gras également
    objFeuille.Columns("A").Font.Bold = True
    ' On écrit la 1ère rangée
    objFeuille.Cells(1, 1).Value = "Nom du bloc"
    objFeuille.Cells(1, 2).Value = "Calque"
    objFeuille.Cells(1, 3).Value = "Echelle"
    objFeuille.Cells(1, 4).Value = "Coord en X Pt Insert"
    objFeuille.Cells(1, 5).Value = "Coord en Y Pt Insert"
    objFeuille.Cells(1, 6).Value = "Attribut N°1"
    objFeuille.Cells(1, 7).Value = "Attribut N°2"
    objFeuille.Cells(1, 8).Value = "Attribut N°3"
    ' on écrit la liste qui suit à partir de la 3ème rangée
    RangNum = 3
    
    ' on balaye le dessin entier
    For Each objElem In ThisDrawing.ModelSpace
      ' si l'élément est un bloc
      If objElem.EntityType = acBlockReference Then
         ' met le Nom dans la 1ère colonne
         objFeuille.Cells(RangNum, 1).Value = objElem.Name
         ' met le nom du calque dans la 2ème colonne, etc...
         objFeuille.Cells(RangNum, 2).Value = objElem.Layer
         objFeuille.Cells(RangNum, 3).Value = objElem.XScaleFactor
         PtInsert = objElem.insertionPoint
         objFeuille.Cells(RangNum, 4).Value = PtInsert(0)
         objFeuille.Cells(RangNum, 5).Value = PtInsert(1)
         ' les attributs sont stockés dans un tableau
         tablAttrib = objElem.GetAttributes
         For Cpt1 = LBound(tablAttrib) To UBound(tablAttrib)
         ' si vous préférez avoir la liste des étiquettes au lieu
         ' de leur valeur, remplacez TextString par TagString
           objFeuille.Cells(RangNum, Cpt1 + 6).Value = tablAttrib(Cpt1).TextString
         Next
       
         RangNum = RangNum + 1
      End If
    Next objElem
    ' on détermine la dernière cellule de la feuille
    CellFin = "H" & RangNum
    ' tri ascendant selon colonne A puis colonne B
    objFeuille.Range("A2", CellFin).Sort key1:=objFeuille.Columns("A"), key2:=objFeuille.Columns("B")
    ' justification à gauche des colonnes A et B
    objFeuille.Columns("A:B").HorizontalAlignment = 2
    ' Ajustement automatique de la largeur des colonnes
    objFeuille.Columns.AutoFit
    ' on change le nom de la feuille
    AppExcel.Sheets("Feuil1").Name = "Blocs"
    
End Sub

Private Sub ListCalques()
    ' Procédure d'élaboration de la liste des calques
    Dim objElem As Object       ' objet collection des calques
    Dim objFeuille As Object
    Dim Cpt1, I, RangNum, NumColor As Integer
    Dim CoulCalc As Variant
    Dim objCalque As Object     ' objet Calque
    Dim Couleurs(7), CellFin As String
    
    Couleurs(1) = "rouge"
    Couleurs(2) = "jaune"
    Couleurs(3) = "vert"
    Couleurs(4) = "cyan"
    Couleurs(5) = "bleu"
    Couleurs(6) = "magenta"
    Couleurs(7) = "blanc"
    
    ' on travaille avec Feuil2
    ' si Excel en version US, remplacez Feuil2 par Sheet2
    AppExcel.Sheets("Feuil2").Select
    Set objFeuille = AppExcel.ActiveWorkbook.Sheets("Feuil2")
    ' en gras
    objFeuille.Rows("1").Font.Bold = True
    objFeuille.Columns("A").Font.Bold = True
    ' On écrit la 1ère rangée
    objFeuille.Cells(1, 1).Value = "Nom du Calque"
    objFeuille.Cells(1, 2).Value = "Couleur"
    objFeuille.Cells(1, 3).Value = "Type de lignes"
    objFeuille.Cells(1, 4).Value = "Gelé"
    objFeuille.Cells(1, 5).Value = "Verrouillé"
    ' on écrit la liste à partir de la 3ème rangée
    RangNum = 3
    objFeuille.Columns("A:C").VerticalAlignment = 2
    Set objElem = ThisDrawing.Layers
    ' nombre de calques
    Cpt1 = objElem.Count
    For I = 0 To Cpt1 - 1
       Set objCalque = objElem(I)
         ' met le Nom dans la 1ère colonne
       objFeuille.Cells(RangNum, 1).Value = objCalque.Name
         ' met la couleur dans la 2ème colonne, etc...
       NumColor = objCalque.Color
       If NumColor < 8 Then
          ' remplace le numéro de couleur par son nom
          CoulCalc = Couleurs(NumColor)
          Else
          CoulCalc = Str(NumColor)
       End If
       objFeuille.Cells(RangNum, 2).Value = CoulCalc
       objFeuille.Cells(RangNum, 3).Value = objCalque.Linetype
       ' si le calque est gelé
       If objCalque.Freeze = True Then
         objFeuille.Cells(RangNum, 4).Value = "Gelé"
       End If
       If objCalque.Lock = True Then
         objFeuille.Cells(RangNum, 5).Value = "Verrouillé"
       End If
       RangNum = RangNum + 1
    Next I
    CellFin = "E" & RangNum
    objFeuille.Range("A2", CellFin).Sort key1:=objFeuille.Columns("A")
    objFeuille.Columns("A:C").HorizontalAlignment = 2
    objFeuille.Columns.AutoFit
    ' on change le nom de la feuille
    AppExcel.Sheets("Feuil2").Name = "Calques"
    
End Sub

Private Sub ListTypLignes()
    ' Procédure d'élaboration de la liste des types de lignes
    Dim objElem As Object           ' objet collection type de lignes
    Dim objFeuille As Object
    Dim Cpt1, I, RangNum As Integer
    Dim objTLigne As Object
    Dim CellFin As String

    AppExcel.Sheets("Feuil3").Select
    Set objFeuille = AppExcel.ActiveWorkbook.Sheets("Feuil3")
    ' en gras
    objFeuille.Rows("1").Font.Bold = True
    objFeuille.Columns("A").Font.Bold = True
    ' On écrit la 1ère rangée
    objFeuille.Cells(1, 1).Value = "Type de Ligne"
    objFeuille.Cells(1, 2).Value = "Description"
    ' on écrit la liste à partir de la 3ème rangée
    RangNum = 3
    
    Set objElem = ThisDrawing.Linetypes
    Cpt1 = objElem.Count
    For I = 0 To Cpt1 - 1
       Set objTLigne = objElem(I)
         ' met le Nom dans la 1ère colonne
       objFeuille.Cells(RangNum, 1).Value = objTLigne.Name
         ' met la description dans la 2ème colonne
       objFeuille.Cells(RangNum, 2).Value = objTLigne.Description
       RangNum = RangNum + 1
    Next I
    CellFin = "H" & RangNum
    objFeuille.Range("A2", CellFin).Sort key1:=objFeuille.Columns("A")
    objFeuille.Columns.AutoFit
    ' on change le nom de la feuille
    AppExcel.Sheets("Feuil3").Name = "Types de Lignes"

End Sub

Private Sub ListStyleText()
    ' Procédure d'élaboration de la liste des styles de texte
    Dim objElem As Object       ' objet collection style de texte
    Dim objFeuille As Object
    Dim Cpt1, I, RangNum As Integer
    Dim objStyle As Object
    Dim CellFin As String

    ' on ajoute une nouvelle feuille dans Excel
    AppExcel.Sheets.Add
    AppExcel.Sheets("Feuil4").Select
    ' on travaille avec Feuil4
    Set objFeuille = AppExcel.ActiveWorkbook.Sheets("Feuil4")
    ' en gras
    objFeuille.Rows("1").Font.Bold = True
    objFeuille.Columns("A").Font.Bold = True
    ' On écrit la 1ère rangée
    objFeuille.Cells(1, 1).Value = "Style de Texte"
    objFeuille.Cells(1, 2).Value = "Nom du Fichier"
    objFeuille.Cells(1, 3).Value = "Hauteur"
    objFeuille.Cells(1, 4).Value = "Fact. Extension"
    objFeuille.Cells(1, 5).Value = "Inclinaison"
    objFeuille.Cells(1, 6).Value = "Reflété"
    objFeuille.Cells(1, 7).Value = "Renversé"
 
    ' on écrit la liste à partir de la 3ème rangée
    RangNum = 3
    
    Set objElem = ThisDrawing.TextStyles
    Cpt1 = objElem.Count
    For I = 0 To Cpt1 - 1
       Set objStyle = objElem(I)
         ' met le Nom dans la 1ère colonne
       objFeuille.Cells(RangNum, 1).Value = objStyle.Name
         ' met le nom du fichier dans la 2ème colonne, etc...
       objFeuille.Cells(RangNum, 2).Value = objStyle.fontfile
       objFeuille.Cells(RangNum, 3).Value = objStyle.Height
       objFeuille.Cells(RangNum, 4).Value = objStyle.Width
       ' angle d'inclinaison en radians transformé en degrés
       objFeuille.Cells(RangNum, 5).Value = objStyle.ObliqueAngle * 57.295779513
       If objStyle.TextGenerationFlag = 2 Or objStyle.TextGenerationFlag = 6 Then
          objFeuille.Cells(RangNum, 6).Value = "reflété"
       End If
       If objStyle.TextGenerationFlag = 4 Or objStyle.TextGenerationFlag = 6 Then
          objFeuille.Cells(RangNum, 7).Value = "renversé"
       End If
       
       RangNum = RangNum + 1
    Next I
      CellFin = "H" & RangNum
    objFeuille.Range("A2", CellFin).Sort key1:=objFeuille.Columns("A")
    objFeuille.Columns.AutoFit
    ' on change le nom de la feuille
    AppExcel.Sheets("Feuil4").Name = "Styles de Texte"

End Sub

Private Sub cmdAnnuler_Click()
    Unload Me
End Sub