Dans le programme précédent, Descript2, on copie une base existante modèle et on remplit les tables ensuite.
L'exemple de ce chapître, Descript3, n'a nul besoin de base modèle, il crée lui-même la base de données, les tables et les différents champs qu'il complète ensuite.

Pour accéder à Access on continuera à utiliser le moteur de base de données Microsoft Jet à l'aide de la bibliothèque DAO.

Pour commencer, vérifiez si la case Microsoft DAO 3.5 Object Library dans la boîte Références du menu Outils de VBA est bien cochée.

• Au sommet de la hiérarchie DAO, l'objet DBEngine qui contrôle tous les objets sous sa descendance.
• L'objet Database correspond à la base de données qui sera créée dans l'objet Workspace. à l'aide de la méthode CreateDatabase.
• Pour créer les tables dans l'objet Database on dispose de la méthode CreateTableDef qui génère un objet TableDef dépourvu de tout champ.
• L'objet TableDef possède la méthode CreateField qui permet d'ajouter des champs dans la table.
• L'objet Field nécessite d'être attaché à l'objet TableDef. Pour cela, on utilise la méthode Append de la collection Fields de l'objet TableDef. A faire pour chaque champ.
• On procède de la même manière pour créer un objet Index.
• Pour terminer la création d'une table, il faut ajouter l'objet TableDef à la collection TableDefs à l'aide de la méthode Append.



• Pour remplir les tables, on utilisera, comme avec Descript2, les objets Recordset à l'aide de la méthode OpenRecordset.

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

• Dans Sub Descript3 on recherche le nom du dessin pour donner le même nom la base de donnée.
  
• Si une base de ce nom existe déjà, elle sera effacée, sans mise en garde.
• Set dbAcc = wrkDefault.CreateDatabase(FichAccess, dbLangGeneral, dbVersion30) crée la base de données.
  
• FichAccess : Nom de la base, avec éventuellement le chemin
• dbLangGeneral : variable concernant l'odre de tri - Toujours ça en français ou anglais. On peut y ajouter un mot de passe : dbLangGeneral & ";pwd=sesame"
• dbVersion30 : version du format de données.

    Option Explicit
    'Initialisation des variables
    Public wrkDefault As Workspace      '
    Public dbAcc As Database            ' Variable objet de la base de données
    Public FichAccess As String         ' Nom du fichier avec le chemin

Public Sub Descript3()
    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"	' si le dessin n'a pas encore de nom
    End If
    
    ' Obtient l'objet Workspace par défaut.
    Set wrkDefault = DBEngine.Workspaces(0)
    ' Vérifie qu'aucun fichier ne porte le nom de la nouvelle base de données.
    If Dir(FichAccess) <> "" Then Kill FichAccess
    ' Crée une nouvelle base de données
    Set dbAcc = wrkDefault.CreateDatabase(FichAccess, dbLangGeneral, dbVersion30)
    UserForm1.Show
    
End Sub
    

Quand on clique sur le bouton Créer les listes :
• Création puis enregistrement des tables choisies
• Fermeture et déchargement de la base de données.
• Procédure inchangée par rapport à Descript2 .

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

• Création de la table Blocs
  
• Création des champs
  
• Création de l'index
  
• 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 TBlocs As TableDef
    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
    Dim idxNom As Index             ' index de la table
    ' Création de la table Blocs
    Set TBlocs = dbAcc.CreateTableDef("Blocs")
    ' Création des champs et ajout dans la collection fields
    With TBlocs
        .Fields.Append .CreateField("Nom du bloc", dbText, 50)
        .Fields.Append .CreateField("Calque", dbText, 20)
        .Fields.Append .CreateField("Echelle", dbSingle)
        .Fields.Append .CreateField("Coord en X", dbDouble)
        .Fields.Append .CreateField("Coord en Y", dbDouble)
        .Fields.Append .CreateField("Attribut1", dbText, 50)
        .Fields.Append .CreateField("Attribut2", dbText, 50)
        .Fields.Append .CreateField("Attribut3", dbText, 50)
        .Fields.Append .CreateField("Attribut4", dbText, 50)
        .Fields.Append .CreateField("Attribut5", dbText, 50)
        ' on ajoute un index pour avoir d'office un classement par ordre alphabétique
        Set idxNom = .CreateIndex("IndexNom")
        With idxNom
            .Fields.Append .CreateField("Nom du bloc")
        End With
        .Indexes.Append idxNom
    End With
    ' on ajoute le tout dans la collection TableDefs
    dbAcc.TableDefs.Append TBlocs
    ' Permission d'avoir un champ nul pour les attributs
    TBlocs("Attribut1").AllowZeroLength = True
    TBlocs("Attribut2").AllowZeroLength = True
    TBlocs("Attribut3").AllowZeroLength = True
    TBlocs("Attribut4").AllowZeroLength = True
    TBlocs("Attribut5").AllowZeroLength = True
    ' Fin de la partie création de la table 
    ' Ouverture du Recordset
    Set Blocs = dbAcc.OpenRecordset("Blocs")
    ' 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 (tablAttrib(Cpt1).TextString) <> "" Then
               ' 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 TdCalques As TableDef
    Dim Calques As Recordset
    Dim objCalque As AcadLayer    ' objet Calque
    Dim NumColor As Integer
    Dim CoulCalc As Variant
    Dim Couleurs(7) As String
    Dim idxNom As Index             ' index de la table

    Couleurs(1) = "rouge"
    Couleurs(2) = "jaune"
    Couleurs(3) = "vert"
    Couleurs(4) = "cyan"
    Couleurs(5) = "bleu"
    Couleurs(6) = "magenta"
    Couleurs(7) = "blanc"
    
     ' on crée la table Calque
    Set TdCalques = dbAcc.CreateTableDef("Calques")
    With TdCalques
        .Fields.Append .CreateField("NomCalque", dbText, 50)
        .Fields.Append .CreateField("Couleur", dbText, 10)
        .Fields.Append .CreateField("TypeLigne", dbText, 50)
        .Fields.Append .CreateField("Gelé", dbText, 10)
        .Fields.Append .CreateField("Verrouillé", dbText, 10)
        ' on ajoute un index pour avoir d'office un classement par ordre alphabétique
        Set idxNom = .CreateIndex("IndexNom")
        With idxNom
            .Fields.Append .CreateField("NomCalque")
        End With
        .Indexes.Append idxNom
     End With
    ' on ajoute dans la collection TableDefs
    dbAcc.TableDefs.Append TdCalques
    ' 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é = "Gelé"
       End If
       If objCalque.Lock = True Then
            Calques!Verrouillé = "Verrouillé"
       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 TdLignes As TableDef
    Dim TypesLigne As Recordset
    Dim objElem As Object           ' objet collection type de lignes
    Dim idxNom As Index             ' index de la table

    ' on crée la table TypesLigne
    Set TdLignes = dbAcc.CreateTableDef("TypesLigne")
    With TdLignes
        .Fields.Append .CreateField("Type de Ligne", dbText, 50)
        .Fields.Append .CreateField("Description", dbText, 255)
        ' on ajoute un index pour avoir d'office un classement par ordre alphabétique
        Set idxNom = .CreateIndex("IndexNom")
        With idxNom
            .Fields.Append .CreateField("Type de Ligne")
        End With
        .Indexes.Append idxNom
    End With
    ' on ajoute les champs dans la collection TableDefs
    dbAcc.TableDefs.Append TdLignes
    ' Permission d'avoir un champ nul
    TdLignes("Description").AllowZeroLength = True
    ' 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 TdStyles As TableDef
    Dim StylesTexte As Recordset
    Dim objElem As Object           ' objet collection style de texte
    Dim idxNom As Index             ' index de la table
    
    ' on crée la table StylesTexte
    Set TdStyles = dbAcc.CreateTableDef("StylesTexte")
    
    With TdStyles
        .Fields.Append .CreateField("Style de texte", dbText, 50)
        .Fields.Append .CreateField("Nom de fichier", dbText, 50)
        .Fields.Append .CreateField("Hauteur", dbDouble)
        .Fields.Append .CreateField("Facteur Extension", dbDouble)
        .Fields.Append .CreateField("Inclinaison", dbSingle)
        .Fields.Append .CreateField("Reflété", dbText, 10)
        .Fields.Append .CreateField("Renversé", dbText, 10)
        Set idxNom = .CreateIndex("IndexNom")
        With idxNom
            .Fields.Append .CreateField("Style de texte")
        End With
        .Indexes.Append idxNom
    End With
    ' on ajoute dans la table
    dbAcc.TableDefs.Append TdStyles
    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é = "Reflété"
       End If
       If objElem.TextGenerationFlag = 4 Or objElem.TextGenerationFlag = 6 Then
          StylesTexte!Renversé = "Renversé"
       End If
       StylesTexte.Update
    Next objElem
    StylesTexte.Close
    Set StylesTexte = Nothing

End Sub

Private Sub cmdAnnuler_Click()
    Unload Me
End Sub