MAJ structure tables

**Ric500** · 29/05/2018, 09h54

Bonjour,

Je cherche à parfaire un utilitaire de mise à jour pour mes bdd. Concernant les objets sauf les tables, ma solution fonctionne. Mais il arrive que ma version de développement évolue et j'aimerais écrire une routine en vba pour mettre à jour la structure des tables en production, voire créer les tables manquantes à partir de la structure de celles de la version de développement.
J'intuite qu'il faut parcourir en parallèle la collection tables et leurs collections properties pour ce faire, mais j'avoue que je cale un peu quant à la méthode.

Merci de vos lumières

**nico84** · 29/05/2018, 14h16

Bonjour,

Envoyé par Ric500

voire créer les tables manquantes à partir de la structure de celles de la version de développement.

Si ces tables sont dans une dorsale, celle-ci n'est pas directement impactée par le changement de version
Pour ma part je fais donc toutes les modifications de la dorsale avec des "patch", ce qui permet de les appliquer à toutes les dorsales en service ou en développement
Il y a un très bon tuto ici : http://warin.developpez.com/access/dao/

**Ric500** · 29/05/2018, 15h20

Merci Nico84 pour ta réponse rapide,

Je regarde ce tuto et reviens vers vous pour clore ce billet

**Ric500** · 03/07/2018, 14h39

Bonjour à tous,

Je me permets de relancer ce billet car, si j'ai avancé dans ma problématique, c'est pas encore "gagné".

A l'heure actuelle, mon patch peut:
. Ajouter les tables manquantes
. Recréer les relations à l'identique

Il me manque:
. la possibilité de rajouter des champs manquants dans la dorsale à mettre à jour,
. leur donner les éventuelles propriétés d'index, taille, type, attributs
.
J'avoue que je me perds un peu dans le tuto de Christophe WARIN, même s'il est très complet.

Mon appli de mise à jour des dorsales comporte un formulaire permettant de choisir une base "Source" et une base "Destination" + un bouton qui déclence la procédure suivante:

Nom : Sans titre.png
Affichages : 149
Taille : 20,3 Ko

Nom : Sans titre.png
Affichages : 149
Taille : 20,3 Ko

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Private Sub Commande5_Click()
    Dim x As Integer, y  As Integer
    Dim wrkDefaultSource As Workspace
    Dim wrkDefaultDest As Workspace
    Dim dbsSource As Database
    Dim dbsDest As Database
    Dim tdfloop As TableDef
    Dim TableSource As String, TableDest As String, BoolTrouve As Boolean
    Dim laTableSource As TableDef, laTableDest As TableDef
    Dim fldSource As Field, fldDest As Field, leChamp As Field, BoolTrouveFld As Boolean
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsSource = wrkDefault.OpenDatabase(Source)
    Set dbsDest = wrkDefault.OpenDatabase(Destination)
    BoolTrouve = False
    
    With dbsSource
        For x = 0 To .TableDefs.Count - 1
            TableSource = .TableDefs(x).Name
            
            '''Cherche la table dans la bd destination
            With dbsDest
                For Each tdfloop In .TableDefs
                    If tdfloop.Name = TableSource Then
                        BoolTrouve = True
                        Else
                        BoolTrouve = False
                    End If
                    If BoolTrouve = False Then
                        '''Table inexistante => Import
                        DoCmd.TransferDatabase acExport, "Microsoft Access", Source, acTable, TableSource, TableSource & "Temp"
                        Call ViderTable(TableSource & "Temp")
                        DoCmd.Rename TableSource, acTable, TableSource & "Temp"
                        Else
                        '''Table existante => Vérifie leur structure
                        For Each fldSource In dbsSource.TableDefs(x).Fields
                            For Each fldDest In tdfloop.Fields
                                If fldDest.Name = fldSource.Name Then
                                    BoolTrouveFld = True
                                    Else
                                    BoolTrouveFld = False
                                End If
                                If BoolTrouveFld = True Then
                                    '''Vérifie propriétés et les modifie si besoin
                                    '''ICI comparaison Type, Taille, Attributs, Index et MAJ éventuelle
                                    Else
                                    '''Crée champ
                                    '''ICI Création du champ manquant et MAJ Type, Taille, Attributs, Index
                                End If
                                BoolTrouveFld = False
                            Next fldDest
                        Next fldSource
                        
                        BoolTrouve = False
                    End If
                Next tdfloop
            End With
            
TblSuite:
        Next x
    End With
    
    
    Set laTableSource = Nothing
    Set laTableDest = Nothing
    Set dbsource = Nothing
    Set dbsDest = Nothing
    Set tdfloop = Nothing
    Set wrkDefault = Nothing
    
    '''Crée les relations à l'identique entre Source et destination
    Call CréeRelSauvegarde(Source, Destination)
End Sub

Je fais appel à vos lumières car mon appli évoluant, les versions s'enchaînent et deviennent de plus en plus difficiles à maintenir.

Merci encore

**nico84** · 03/07/2018, 19h10

Chez moi le patch est intégré à la frontale et il s'applique tout seul s'il voit que la dorsale est dans une version inférieure à la frontale

J'utilise pour cela une fonction creechamp qui peut appeler si besoin les fonctions creeindex et creerelation. Elle fait aussi appel à un fichier texte xxx.ini qui contient la liste des tables attendues
Enfin, ces fonctions sont compatibles access ou SQL server donc il faut y faire un peu de tri

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
'CreeChamp(odb,Table,nv Y/N,Champ,Typ (dbX),lg,Auto,Required Y/N,Vide Y/N,Defaut Str,Valid Str,Descr,Clef/Primaire/Unique,RT,RC)
'RT : table qui contient la clé primaire, RC : nom de la clé primaire dans cette table (identique par défaut)
'9.42 Création de tables, champs, index et ajoute une ligne au .ini - source :
'http://warin.developpez.com/access/dao/?page=partie_4#L4.4.4.1 
Public Sub CreeChamp(odb, table As String, nv As Boolean, champ As String, typ As Integer, lg As Integer, auto As Boolean _
, req As Boolean, vide As Boolean, defaut As String, Valid As String, Descr As String, Optional clef As String = "" _
, Optional RT As String = "", Optional rc As String = "")
If Not Mode_debug Then On Error GoTo err
Dim oTbl As DAO.TableDef, oFld As DAO.Field, prp As DAO.Property
Dim FSO As New Scripting.FileSystemObject, FileText As Scripting.TextStream, T As String
 
102 If nv Then
      'Ouvre le .ini et ajoute une ligne - 12.2f nom variable
104   Set FileText = FSO.OpenTextFile(Planet_ini, ForAppending, False)
106   FileText.WriteLine table & Space(15 - Len(table)) & "=*" '15.9 même source que la table précédente par défaut - ald Planet_db
108   FileText.Close: Set FileText = Nothing
109   Set FSO = Nothing
    End If
 
110 If msql Then  'TODO vide et auto ne sont pas pris en charge ici !
120   If nv Then
122     Sr = "CREATE TABLE [dbo].[" & table & "] ([" & champ & "]"
      Else
130     Sr = "ALTER TABLE [dbo].[" & table & "] ADD [" & champ & "]"
      End If
140   Select Case typ
      Case dbInteger: Sr = Sr & " smallint"
      Case dbLong: Sr = Sr & " int"
      Case dbText: Sr = Sr & " nvarchar(" & lg & ")"
      Case dbMemo: Sr = Sr & " nvarchar(max)"
      Case dbBoolean: Sr = Sr & " bit"
      Case dbSingle: Sr = Sr & " real"
      Case dbDouble: Sr = Sr & " float"
      Case dbDate: Sr = Sr & " datetime"
      Case dbLongBinary: Sr = Sr & " varbinary(max)" '16.8a ald " image"
      Case Else: Call message("erreur " & typ & " non prévu dans fonctions.creechamp" & table & "." & champ)
      End Select
150   Sr = Sr & IIf(req, " NOT ", "") & " NULL" 'attention si NOT NULL la table doit être vide !
152   If defaut > " " Then
154     If IsNumeric(defaut) Then Sr = Sr & " DEFAULT (" & defaut & ")" Else Sr = Sr & " DEFAULT ('" & defaut & "')"
      End If
160   If nv Then 'exemple copié depuis la pk de HG.dbo.stock : déclare la clé primaire
162     Sr = Sr & ", CONSTRAINT [pk_" & table & "] PRIMARY KEY CLUSTERED ([" & champ & "] ASC) WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]) ON [PRIMARY]"
      End If
'      MsgBox Sr
170   cnx.Execute Sr
      'description pour info - TODO : validation, contraintes
172   Sr = "sp_addextendedproperty @name = 'Description', @value = '" & Apo2(Descr) & "', @level0type = 'Schema', @level0name = 'dbo'" _
      & ", @level1type = 'Table',  @level1name = '" & table & "', @level2type = 'Column', @level2name = '" & champ & "';"
174   cnx.Execute Sr
    Else
212   If nv Then Set oTbl = odb.CreateTableDef(table) Else Set oTbl = odb.TableDefs(table)
214   If typ = dbText Then Set oFld = oTbl.CreateField(champ, typ, lg) Else Set oFld = oTbl.CreateField(champ, typ)
216   If auto Then oFld.Attributes = dbAutoIncrField    'Définit le champ en numero_auto
218   oFld.Required = req                               'Null interdit ?
220   If typ = dbText Then oFld.AllowZeroLength = vide  'chaine vide autorisée ?
222   If Len(defaut) > 0 Then oFld.DefaultValue = defaut
224   If Len(Valid) > 0 Then oFld.ValidationRule = Valid
226   oTbl.Fields.Append oFld 'Ajoute le champ à la table
228   If nv Then odb.TableDefs.Append oTbl   'Ajoute la table à la base de données
230   If Nz(Descr) > " " Then
232     Set prp = oFld.CreateProperty("Description", dbText, Descr)
234     oFld.Properties.Append prp
      End If
236   If typ = dbBoolean Then
238     Set prp = oFld.CreateProperty("Format", dbText, "Yes/No")
240     oFld.Properties.Append prp    'Format oui/non
242     Set prp = oFld.CreateProperty("DisplayControl", dbInteger, 106)
244     oFld.Properties.Append prp    'case à cocher
      End If
246   oTbl.Fields.refresh           'Rafraichit la collection
248   odb.TableDefs.refresh
254   Set prp = Nothing
256   Set oFld = Nothing
258   Set oTbl = Nothing
 
300   If Len(RT) > 0 Then Call CreeRelation(odb, table, champ, RT, rc)  'TODO MSQL
    End If
302 If Len(clef) = 1 Then Call CreeIndex(odb, table, champ, clef)
    Exit Sub
err: Call message("Erreur " & err.Number & "/" & Erl & " dans fonctions.CreeChamp " & table & "." & champ & " : " & err.description)
End Sub
 
'10.1e ajout d'un index sur un champ
Public Sub CreeIndex(odb, table As String, champ As String, clef As String)
If Not Mode_debug Then On Error GoTo err
Dim oTbl As DAO.TableDef, oFld As DAO.Field, oind As DAO.Index
 
100 If msql Then
102   If clef = "C" Or clef = "U" Then  'index : le 1er champ est d'office la PK
104     Sr = "CREATE" & IIf(clef = "U", "UNIQUE", "") & " NONCLUSTERED INDEX [" & table & "_" & champ & "] ON [dbo].[" & table & "] ([" & champ _
        & "] ASC) WITH (PAD_INDEX=OFF, STATISTICS_NORECOMPUTE=OFF, SORT_IN_TEMPDB=OFF, DROP_EXISTING=OFF, ONLINE=OFF, ALLOW_ROW_LOCKS=ON, ALLOW_PAGE_LOCKS=ON) ON [PRIMARY]"
'        MsgBox Sr
106     cnx.Execute Sr
      End If
    Else
112   Set oTbl = odb.TableDefs(table)
114   Set oind = oTbl.CreateIndex(champ)   'Crée l'index du même nom
116   Set oFld = oind.CreateField(champ)
118   oind.Fields.Append oFld                   'Ajoute le champ à la collection Fields
120   Select Case clef
      Case "C":  oind.Unique = False  'standard
      Case "P":  oind.Primary = True  'primaire
      Case "U":  oind.Unique = True   'unique
      Case Else: Call message("cas non prévu en création de la clé " & champ & " sur " & table)
      End Select
122   oTbl.Indexes.Append oind                  'Ajoute l'index à la table
124   oTbl.Indexes.refresh                      'Rafraichit la collection
126   Set oFld = Nothing
128   Set oind = Nothing
130   Set oTbl = Nothing
    End If
    Exit Sub
err: Call message("Erreur " & err.Number & "/" & Erl & " dans fonctions.CreeIndex sur " & table & "." & champ & " : " & err.description)
End Sub
 
'10.1f ajout d'une relation entre 2 champs RT = table maitresse, RC = champ maitre si nom différent
Public Sub CreeRelation(odb, table As String, champ As String, RT As String, Optional rc As String = "")
If Not Mode_debug Then On Error GoTo err
Dim oFld As DAO.Field, oRlt As DAO.Relation, c As String
 
100 c = IIf(Len(rc) > 0, rc, champ)
102 Set oRlt = odb.CreateRelation(RT & "_" & table & "_" & champ, RT, table, dbRelationUpdateCascade) 'Crée la relation
104 Set oFld = oRlt.CreateField(c)
106 oFld.ForeignName = champ     'Définit la clé externe
108 oRlt.Fields.Append oFld      'Ajoute le champ
110 odb.Relations.refresh        'Rafraîchit la collection Relations
112 odb.Relations.Append oRlt    'Ajoute la relation
114 odb.Relations.refresh        'Rafraîchit la collection Relations
 
116 Set oRlt = Nothing
118 Set oFld = Nothing
    Exit Sub
err: Call message("Erreur " & err.Number & "/" & Erl & " dans fonctions.CreeRelation sur " & table & "." & champ & " : " & err.description)
End Sub

**Ric500** · 04/07/2018, 14h42

Bonjour à tous et merci Nico84 pour ta réactivité

Je progresse, mais je cale encore sur certains points:

J'ai réussi à:
. rajouter des champs manquants dans la dorsale à mettre à jour,

Il me manque:
. la mise à jour (modification) des éventuelles propriétés d'index, taille, type, attributs qui auraient pu évoluer dans la version de développement

Je me heurte à l'erreur 3219 (opération non valide) => propriété en lecture seule

Voici ma procédure appelante:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
Private Sub Commande5_Click()
    Dim x As Integer, y  As Integer, strSQL As String
    Dim wrkDefaultSource As Workspace
    Dim wrkDefaultDest As Workspace
    Dim dbsSource As Database
    Dim dbsDest As Database
    Dim tdfloop As TableDef
    Dim TableSource As String, TableDest As String, BoolTrouve As Boolean
    Dim laTableSource As TableDef, laTableDest As TableDef
    Dim fldSource As Field, fldDest As Field, leChamp As Field, BoolTrouveFld As Boolean
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsSource = wrkDefault.OpenDatabase(Source)
    Set dbsDest = wrkDefault.OpenDatabase(Destination)
    BoolTrouve = False
    
    With dbsSource
        For x = 0 To .TableDefs.Count - 1
            TableSource = .TableDefs(x).Name
            TableDest = .TableDefs(x).Name
            '''Cherche la table dans la bd destination
            With dbsDest
                For Each tdfloop In .TableDefs
                    If tdfloop.Name = TableSource Then
                        BoolTrouve = True
                        Exit For
                        Else
                        BoolTrouve = False
                    End If
                Next tdfloop
                If BoolTrouve = False Then
                    '''Table inexistante => Import
                    DoCmd.TransferDatabase acExport, "Microsoft Access", Source, acTable, TableSource, TableSource & "Temp"
                    Call ViderTable(TableSource & "Temp")
                    DoCmd.Rename TableSource, acTable, TableSource & "Temp"
                    Else
                    '''Table existante => Vérifie leur structure
                    For Each fldSource In dbsSource.TableDefs(x).Fields
                        For Each fldDest In tdfloop.Fields
                            If fldDest.Name = fldSource.Name Then
                                BoolTrouveFld = True
                                Exit For
                                Else
                                BoolTrouveFld = False
                            End If
                        Next fldDest
                        If BoolTrouveFld = True Then
                            '''Vérifie propriétés et les modifie si besoin
                            If fldDest.Type <> fldSource.Type Or fldDest.size <> fldSource.size Then
                                Call ChangeFields(Destination, TableDest, fldDest.Name, fldSource.Type, fldSource.size)
                            End If
                            Else
                            '''Crée champ
                            Set laTableDest = dbsDest.TableDefs(TableDest)
                            Set leChamp = laTableDest.CreateField(fldSource.Name)
                            leChamp.Type = fldSource.Type
                            leChamp.size = fldSource.size
                            leChamp.Attributes = fldSource.Attributes
                            laTableDest.Fields.Append leChamp
                        End If
                        
                        BoolTrouveFld = False
                    Next fldSource
                    
                End If
                BoolTrouve = False
            End With
            
TblSuite:
        Next x
    End With
    
    
    Set laTableSource = Nothing
    Set laTableDest = Nothing
    Set leChamp = Nothing
    Set dbsource = Nothing
    Set dbsDest = Nothing
    Set tdfloop = Nothing
    Set wrkDefault = Nothing
    
    '''Crée les relations à l'identique entre Source et destination
    Call CréeRelSauvegarde(Source, Destination)
End Sub

Voici ma procédure de modification:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub ChangeFields(nameBase, nameTbl, nameFld, typFld, sizFld)
    Dim db As Database
    Dim TD As TableDef
    Dim fld As Field
    Dim strSQL As String, leTyp As String
    Dim prop As DAO.Property
    Set db = DBEngine.Workspaces(0).OpenDatabase(nameBase)
    For Each TD In db.TableDefs
        If TD.Name = nameTbl Then
            For Each fld In TD.Fields
                If fld.Name = nameFld Then
                    fld.Type = typFld
                    fld.size = sizFld
                End If
            Next fld
        End If
    Next TD
    Set db = Nothing
    Set prop = Nothing
    Set fld = Nothing
End Sub