On a vu par le programme Descript comment il était facile d'envoyer des informations vers Excel. Vers Access c'est aussi facile, sinon plus.
Le programme Descript2 qui suit fait la même chose que Descript mais avec le SGDB Access.
Ce programme devrait vous être très utile, à condition de l'adapter à vos besoins réels.

Révision du 2/12/98 : Indexation de certains champs dans la base modèle, code non modifié.

Pour accéder à Access on va utiliser le moteur de base de données Microsoft Jet à l'aide de la bibliothèque DAO.
DAO signifie ici Data Access Objects - Objets d'accès aux données.

Pour commencer, cochez la case Microsoft DAO 3.5 Object Library dans la boîte Références du menu Outils de VBA.

• L'objet DBEngine est l'objet de niveau supérieur du modèle objet DAO. Il contient et contrôle tous les objets de la hiérarchie DAO.
• L'objet Database correspond à la base de données ouverte dans l'objet Workspace.
• La méthode OpenDatabase ouvre la base de données indiquée dans l'objet Workspace et renvoie une référence à l'objet Database qui la représente.
• Un objet Recordset représente les enregistrements d'une table de base ou les enregistrements résultant de l'exécution d'une requête. Avec DAO, les données sont manipulées à l'aide des objets Recordset.
• La méthode OpenRecordset crée l'objet Recordset.

• Table Blocs

  Nom du bloc	Texte	Taille 50 caract	Indexé avec doublons
  Calque	Texte	Taille 20 caract
  Echelle	Numérique	Réel simple
  Coord en X	Numérique	Réel double
  Coord en Y	Numérique	Réel double
  Attribut 1	Texte	Taille 50 caract
  Attribut 2	Texte	Taille 50 caract
  Attribut 3	Texte	Taille 50 caract
  Attribut 4	Texte	Taille 50 caract
  Attribut 5	Texte	Taille 50 caract

  Nota :Ajouter autant d'attributs que leur nombre maximum dans vos blocs



• Table Calques

  NomCalque	Texte	Taille 50 caract	Indexé sans doublons
  Couleur	Texte	Taille 10 caract
  TypeLigne	Texte	Taille 50 caract
  Gelé	Oui/Non	Réel double
  Verrouillé	Oui/Non	Réel double

  
  
• Table StylesTexte

  Style de texte	Texte	Taille 50 caract	Indexé sans doublons
  Nom de fichier	Texte	Taille 50 caract
  Hauteur	Numérique	Réel double
  Facteur Extension	Numérique	Réel double
  Inclinaison	Numérique	Réel simple
  Verrouillé	Oui/Non	Réel double

  
  
• Table TypesLigne

  Type de Ligne	Texte	Taille 50 caract	Indexé sans doublons
  Description	Texte	Taille 255 caract

  
  Nota :
Si vous modifiez les noms des tables ou des champs, n'oubliez pas de les modifier dans le programme.

• 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.
• Dans Sub Descript2 on recherche le nom du dessin puis on copie la base modèle (personnalisez le chemin) en prenant le nom du dessin.
  Si une base de ce nom existe déjà, elle sera effacée, sans mise en garde.
• Set dbAcc = OpenDatabase(FichAccess) ouvre la base de données que l'on vient de copier.
  

    Option Explicit
    'Initialisation des variables
    Public dbAcc As Database            ' Variable objet de la base de données
    Public FichAccess As String         ' Nom du fichier avec le chemin
 
Public Sub Descript2()
    On Error Resume Next
    ' on récupère le nom du dessin
    FichAccess = ThisDrawing.FullName
    ' Pour être sûr que ce n'est pas un dessin sans nom
    If FichAccess <> "" Then
      ' on retire l'extension dwg à la fin du nom
      FichAccess = Left$(FichAccess, Len(FichAccess) - 3)
      ' on ajoute l'extension pour Access
      FichAccess = FichAccess + "mdb"
     Else
      FichAccess = "SansNom.mdb"
    End If
    ' Copie de la base modèle dans le répertoire de travail
    ' modifiez le chemin en fonction de l'emplacement de votre modéle
    FileCopy "c:\acadr14\vbamacro\descript.mdb", FichAccess
    Set dbAcc = OpenDatabase(FichAccess)
    UserForm1.Show
    
End Sub
    

Quand on clique sur le bouton Créer les listes :
• Enregistrement des tables choisies
• Fermeture et déchargement de la base de données.

Private Sub cmdAction_Click()
        
    On Error GoTo 0
    ' 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 ! Fermeture de l'application Access
    dbAcc.Close
    Set dbAcc = Nothing
    Unload Me

End Sub

• Ouverture du Recordset de la table Blocs.
  Un recordset est un jeu d'enregistrements qui correspondent aux critères que vous spécifiez. Si on ne spécifie que la table, le recordset contient tous les enregistrements de cette table.
• Enregistrement de chaque champ sous la forme recordset!champ = valeur ou recordset![champ de foire] = valeur
  Notez le séparateur "!"

ou sous la forme recordset(champ) = valeur si on utilise des variables.

Private Sub ListBlocs()
    ' Procédure d'élaboration de la liste des blocs
    Dim Blocs As Recordset
    Dim objElem As Object           ' objet Elément du dessin
    Dim tablAttrib As Variant       ' tableau des attributs
    Dim Cpt1 As Integer             ' compteur
    Dim PtInsert As Variant         ' point d'insertion du bloc
    Dim chmAttrib                   ' champ attribut
    ' on travaille avec la table Calques
    Set Blocs = dbAcc.OpenRecordset("Blocs", dbOpenDynaset)
    ' on balaye le dessin entier
    For Each objElem In ThisDrawing.ModelSpace
      ' si l'élément est un bloc
      If objElem.EntityType = acBlockReference Then
         Blocs.AddNew
         ' Enregistre le nom du bloc
         Blocs![Nom du bloc] = objElem.Name
         ' Enregistre le nom du calque d'insertion du bloc
         Blocs!Calque = objElem.Layer
         ' Enregistre l'éhelle du bloc
         Blocs!Echelle = objElem.XScaleFactor
         ' Enregistre le nom du bloc
         PtInsert = objElem.insertionPoint
          ' Enregistre les coord. du point d'insertion du bloc
         Blocs![Coord en X] = PtInsert(0)
         Blocs![Coord en Y] = PtInsert(1)
         ' les attributs sont stockés dans un tableau
         tablAttrib = objElem.GetAttributes
         For Cpt1 = LBound(tablAttrib) To UBound(tablAttrib)
           chmAttrib = "Attribut " & (Cpt1 + 1)
           ' si vous préférez avoir la liste des étiquettes au lieu
           ' de leur valeur, remplacez TextString par TagString
           If IsNull(tablAttrib(Cpt1).TextString) Or _
            tablAttrib(Cpt1).TextString = "" Then
              Blocs(chmAttrib) = " "
            Else
              ' Enregistre la valeur de l'attribut du bloc
              Blocs(chmAttrib) = tablAttrib(Cpt1).TextString
           End If
         Next Cpt1
         Blocs.Update
      End If
    Next objElem
    Blocs.Close
    Set Blocs = Nothing
   
End Sub

Private Sub ListCalques()
    ' Procédure d'élaboration de la liste des calques
    Dim Calques As Recordset
    Dim objCalque As AcadLayer    ' objet Calque
    Dim NumColor As Integer
    Dim CoulCalc As Variant
    Dim Couleurs(7) 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 la table Calques
    Set Calques = dbAcc.OpenRecordset("Calques", dbOpenDynaset)
    For Each objCalque In ThisDrawing.Layers
       Calques.AddNew
       ' Enregistrement du nom du calque
       Calques!NomCalque = objCalque.Name
       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
       ' Enregistrement de la couleur du calque
       Calques!Couleur = CoulCalc
       ' Enregistrement du type de ligne du calque
       Calques!TypeLigne = objCalque.Linetype
       ' si le calque est gelé
       If objCalque.Freeze = True Then
            Calques!Gelé = True
       End If
       If objCalque.Lock = True Then
            Calques!Verrouillé = True
       End If
       Calques.Update
    Next objCalque
    Calques.Close
    Set Calques = Nothing
End Sub

Private Sub ListTypLignes()
    ' Procédure d'élaboration de la liste des types de lignes
    Dim TypesLigne As Recordset
    Dim objElem As Object           ' objet collection type de lignes

    ' on travaille avec la table TypesLigne
    Set TypesLigne = dbAcc.OpenRecordset("TypesLigne", dbOpenDynaset)
    For Each objElem In ThisDrawing.Linetypes
       TypesLigne.AddNew
       ' Enregistrement du nom du type de ligne
       TypesLigne![Type de Ligne] = objElem.Name
       ' Enregistrement de la description
       TypesLigne![Description] = objElem.Description
       TypesLigne.Update
    Next objElem
    TypesLigne.Close
    Set TypesLigne = Nothing

End Sub

Private Sub ListStyleText()
    ' Procédure d'élaboration de la liste des styles de texte
    Dim StylesTexte As Recordset
    Dim objElem As Object       ' objet collection style de texte
    
    Set StylesTexte = dbAcc.OpenRecordset("StylesTexte", dbOpenDynaset)
    For Each objElem In ThisDrawing.TextStyles
       StylesTexte.AddNew
       ' Enregistrement du nom du style de texte
       StylesTexte![Style de texte] = objElem.Name
       ' Enregistrement du nom du fichier
       StylesTexte![Nom de fichier] = objElem.fontfile
       ' Enregistrement de la hauteur
       StylesTexte!Hauteur = objElem.Height
       ' Enregistrement du facteur d'extension
       StylesTexte![Facteur Extension] = objElem.Width
       ' angle d'inclinaison en radians transformé en degrés
       StylesTexte!Inclinaison = objElem.ObliqueAngle * 57.295779513
       If objElem.TextGenerationFlag = 2 Or objElem.TextGenerationFlag = 6 Then
          StylesTexte!Reflété = True
       End If
       If objElem.TextGenerationFlag = 4 Or objElem.TextGenerationFlag = 6 Then
          StylesTexte!Renversé = True
       End If
       StylesTexte.Update
    Next objElem
    StylesTexte.Close
    Set StylesTexte = Nothing

End Sub

Private Sub cmdAnnuler_Click()
    Unload Me
End Sub