MISE À JOUR STRUCTURE BASE ACCESS AVEC ADOX

Private Sub Maj_Struct(Dbutilisateur As String, DBReference As String)

'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'Procédure de maj de structure d'une base par rapport à une base référence
'
'Note:
'Les tableaux deltable et delcolumn sont utilisés pour mémoriser les éléments à supprimer, la suppression directe
'étant impossible étant donné qu'une suppression directe boulverse les indices des tables rendant impossible
'la navigation entre les tables de la base
'La suppression intervient donc après avoir mémorisé tous les élements à supprimer
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Dim org_connection As New ADODB.Connection
Dim RcOrg As New ADODB.Recordset
Dim orgcat As New ADOX.Catalog
Dim myconnection As New ADODB.Connection
Dim myrc As New ADODB.Recordset
Dim mycat As New ADOX.Catalog

Dim cu_items() As String
Dim cu_item As Integer
Dim cu_table As Integer
Dim cu_tables() As String
Dim deltable() As String
Dim delcolumn() As String
Dim nbtable As Integer
Dim nbcolumn As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim newtable As ADOX.Table

myconnection.Provider = "Microsoft.jet.oledb.4.0"
myconnection.ConnectionString = Dbutilisateur '"c:\stages\patrice\boadataold.mdb"
myconnection.Open

org_connection.Provider = "Microsoft.jet.oledb.4.0"
org_connection.ConnectionString = DBReference '"c:\stages\patrice\boadataref.mdb"
org_connection.Open

mycat.ActiveConnection = myconnection
orgcat.ActiveConnection = org_connection
cu_table = 0
nbtable = 0
nbcolumn = 0

For i = 0 To orgcat.tables.count - 1
   If orgcat.tables(i).TYPE = "TABLE" Then
       ' on a trouvé une table dans la base de référence
       'recherche de la même table dans la base user
       nbcolumn = 0
       ReDim Preserve cu_tables(cu_table)
       cu_tables(cu_table) = orgcat.tables(i).Name
       cu_table = cu_table + 1
       k = 0
       While k < mycat.tables.count - 1 And mycat.tables(k).Name <> orgcat.tables(i).Name
        k = k + 1
       Wend
       cu_item = 0
       If mycat.tables(k).Name = orgcat.tables(i).Name Then 'si table trouvée dans base user
            'énumération des champs pour ajout
            For j = 0 To orgcat.tables(i).Columns.count - 1 'tq kil y a des champs dans base de références
                ReDim Preserve cu_items(cu_item)
                cu_items(cu_item) = orgcat.tables(i).Columns(j).Name
                cu_item = cu_item + 1
                l = 0
                While l < mycat.tables(k).Columns.count - 1 And mycat.tables(k).Columns(l).Name <> orgcat.tables(i).Columns(j).Name
                    l = l + 1
                Wend
                If mycat.tables(k).Columns(l).Name = orgcat.tables(i).Columns(j).Name Then 'si champ trouvé
                'rien pour l'instant (possibilité peut-être de modification de champ)
                Else
                    'si pas trouvé : Création du champ dans la table
                    mycat.tables(k).Columns.Append orgcat.tables(i).Columns(j).Name, orgcat.tables(i).Columns(j).TYPE, orgcat.tables(i).Columns(j).DefinedSize
                End If
            Next
            
            'suppression des champs dans base user non existant dans base référence
            For j = 0 To (mycat.tables(k).Columns.count - 1)
                m = 0
                While m < cu_item - 1 And cu_items(m) <> mycat.tables(k).Columns(j).Name
                    m = m + 1
                Wend
                If mycat.tables(k).Columns(j).Name = cu_items(m) Then
                    'si champ trouvé
                Else
                    ReDim Preserve delcolumn(nbcolumn)
                    delcolumn(nbcolumn) = mycat.tables(k).Columns(j).Name
                    nbcolumn = nbcolumn + 1
              End If
            Next
        
            For j = 0 To nbcolumn - 1
                m = 0
                While m < mycat.tables(k).Columns.count - 1 And mycat.tables(k).Columns(m).Name <> delcolumn(j)
                    m = m + 1
                Wend
                If mycat.tables(k).Columns(m).Name = delcolumn(j) Then
                    mycat.tables(k).Columns.Delete m
                End If
            Next
            
        Else
            'Création de la table
            Set newtable = New ADOX.Table
            With newtable
                .Name = orgcat.tables(i).Name
                With .Columns
                    For j = 0 To orgcat.tables(i).Columns.count - 1
                        .Append orgcat.tables(i).Columns(j).Name, orgcat.tables(i).Columns(j).TYPE, orgcat.tables(i).Columns(j).DefinedSize
                    Next
                End With
            End With
            mycat.tables.Append newtable
            Set newtable = Nothing
        End If
    End If
Next


For j = 0 To mycat.tables.count - 1
        If mycat.tables(j).TYPE = "TABLE" Then
            m = 0
            While m < cu_table - 1 And cu_tables(m) <> mycat.tables(j).Name
                m = m + 1
            Wend
            If mycat.tables(j).Name = cu_tables(m) Then
                'si table trouvée
            Else
                ReDim Preserve deltable(nbtable)
                deltable(nbtable) = mycat.tables(j).Name
                nbtable = nbtable + 1
            End If
        End If
Next

For j = 0 To nbtable - 1
    m = 0
    While m < mycat.tables.count - 1 And mycat.tables(m).Name <> deltable(j)
        m = m + 1
    Wend
    If mycat.tables(m).Name = deltable(j) Then
        mycat.tables.Delete m
    End If
Next

MsgBox "Import structure terminé", vbInformation, "Import réussi"
org_connection.Close
myconnection.Close
Set org_connection = Nothing
Set myconnection = Nothing
DoCmd.Close acForm, "frmmodifstruct", acSaveNo

End Sub