CRÉATION ASSISTÉE PAR CODE DAO D’UNE TABLE DANS MS ACCESS – NOMBRE ET TYPE DE CHAMPS SELON LES BESOINS.

Option Explicit
        
Sub Test_Creer_Toute_Table()
        Call Creer_Toute_Table(strNomTable:="MaNouvelleTable")
End Sub

        ' Crée une table avec un nombre divers de champs
Function Creer_Toute_Table(strNomTable As String) As Boolean
        On Error GoTo TrappeErreur
        Dim strNomChamp As String
        Dim intTypeChamp As Integer
        Dim tblNouvelleTable As DAO.TableDef
        Dim fldNouveauChamp As DAO.Field
                        
        With CurrentDb
                        ' Vérifie si une table du même nom existe déjà
                If VerifierExistenceTable(strNomTable:=strNomTable) = True Then
                        If MsgBox(Prompt:="Une table nommée " & vbCrLf & _
                                                           strNomTable & vbCrLf & _
                                                           "existe déjà. Désirez-vous continuer et remplacer celle-ci ?", _
                                           Buttons:=vbCritical + vbYesNo, _
                                           Title:="Table existe déjà") = vbNo Then
                                GoTo ExitHere
                        Else
                                        ' Supprime la table existante
                                DoCmd.DeleteObject ObjectType:=acTable, _
                                                                	  ObjectName:=strNomTable
                        End If
                End If
                        ' Crée la table
                Set tblNouvelleTable = .CreateTableDef(strNomTable)
Definir_Champ:
                With tblNouvelleTable
                        strNomChamp = InputBox(Prompt:="Nom du champ", _
                                                                   Title:="Saisir")
                                ' Sort de la fonction s'il  aucun nom n'a été fournit
                        If strNomChamp = vbNullString Then
                                GoTo ExitHere
                        End If
                        On Error Resume Next
            intTypeChamp = InputBox(Prompt:="Nombre correspondant au type de champ;" &  vbCrLf & _
                                                                                  " Booléen       =    1" & vbCrLf & _
                                                                                  " Octet            =    2" & vbCrLf & _
                                                                                  " Entier            =    3" & vbCrLf & _
                                                                                  " Long            =    4" & vbCrLf & _
                                                                                  " Monétaire     =    5" & vbCrLf & _
                                                                                  " Réel simple  =    6" & vbCrLf & _
                                                                                  " Réel double  =    7" & vbCrLf & _
                                                                                  " Date / heure =    8" & vbCrLf & _
                                                                                  " Binaire         =    9" & vbCrLf & _
                                                                                  " Texte            =  10" & vbCrLf & _
                                                                                  " Objet Ole   =  11" & vbCrLf & _
                                                                                  " Mémo           =  12", _
                                                                  Title:="Type de champ", _
                                                                  Default:=10)
                                ' Sort de la fonction si l'inputBox a été annulée
                        If Err.Number = 13 Then
                                GoTo ExitHere
                        End If
                                ' Crée le champ
                        Set fldNouveauChamp = .CreateField(Name:=strNomChamp, _
                                                                                     Type:=intTypeChamp)
                                ' Ajoute le champ à la collection Fields
                        .Fields.Append fldNouveauChamp
                End With
                                ' Vérifie si l'usager désire ajouter un autre champ
                        If MsgBox(Prompt:="Désirez-vous ajouter un autre champ ?", _
                                           Buttons:=vbQuestion + vbYesNo, _
                                           Title:="Nouveau champ") = vbYes Then
                                GoTo Definir_Champ
                        End If
                        ' Ajoute la table à la collection TableDefs
                .TableDefs.Append tblNouvelleTable
        End With
Sortie:
        Set fldNouveauChamp = Nothing
        Set tblNouvelleTable = Nothing
        Exit Function
TrappeErreur:
        MsgBox Err.Description
        Resume Sortie
End Function
    
        ' Verifie si une table existe dans la base de données courante
Function VerifierExistenceTable(strNomTable As String) As Boolean
        Dim tblTable As DAO.TableDef
        
        VerifierExistenceTable = False
        For Each tblTable In CurrentDb.TableDefs
                If tblTable.Name = strNomTable Then
                        VerifierExistenceTable = True
                        Exit For
                End If
        Next
End Function

Télécharger le zip