begin process at 2008 08 22 06:00:51
1 229 779 membres
50 nouveaux aujourd'hui
14 267 membres club

Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !

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


Information sur la source

Catégorie :VBA Classé sous : access, dao, tabledef, fields, vba Niveau : Initié Date de création : 20/07/2007 Vu / téléchargé: 4 473 / 468

Note :
Aucune note

Commentaire sur cette source (0)
Ajouter un commentaire et/ou une note


Description

Voici 2 fonctions pour créer une nouvelle table dans MS Access par code DAO et vérifier s’il n’existe pas déjà dans la base de données une table du même nom.

Voici les étapes de la fonction Creer_Toute_Table :

o vérifie si la table existe déjà et, si elle existe, que l’usager est d’accord pour la remplacer sinon on sort de la fontion
o demande le nom du champ à créer et si aucun nom n’est fournit, on sort de la fonction
o demande le type de champs (choix de 12 types) et sort de la fonction si l’usager annule cette étape
o crée le champ et l’ajoute à la collection Fields
o vérifie si l’usager désire ajouter un autre champ et recommence si oui  et, si non, ajoute la table à la collection TableDefs et termine.
  
L’appel de la fonction se fait ainsi;

Call Creer_Toute_Table(strNomTable:="MaNouvelleTable")

Source

  • 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
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
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
  • Creation_Table.mdbTélécharger ce fichier [Réservé aux membres club]147 456 octets

Télécharger le zip

    Aucun commentaire pour le moment.

Ajouter un commentaire

Pub



Appels d'offres

CalendriCode

Août 2008
LMMJVSD
    123
45678910
11121314151617
18192021222324
25262728293031

VS Express FR Gratuit !

VS Express en français et 100% gratuit !

Téléchargements

Logiciels à télécharger sur le même thème :

Boutique

Boutique de goodies CodeS-SourceS