CLONER UNE TABLE EN ADO

Option Explicit

Declare Function timeGetTime Lib "winmm.dll" () As Long

Public ADORefreshCache  As JRO.JetEngine
Public ADOCurrentDb As ADODB.Connection

Set ADORefreshCache = New JRO.JetEngine


Public Function ClonerTable(ByVal S_Tname As String, ByVal D_Tname As String) As Boolean 'Version ADO
On Error Resume Next
Dim NomChampCle As String
Dim cat      As New ADOX.Catalog
Dim xCount As Integer, prpLoop As Integer
Dim TblField As New ADOX.Column
Dim idxForeign As ADOX.Index

    While ADOCurrentDb.State = 5
        DoEvents
        ADORefreshCache.RefreshCache ADOCurrentDb
    Wend
    Set cat.ActiveConnection = ADOCurrentDb
    
    'Requete pour dupliquer la table
    ADOExecute "SELECT [" & S_Tname & "].* INTO [" & D_Tname & "] FROM [" & S_Tname & "];"
    ADOExecute "DELETE [" & D_Tname & "].* FROM [" & D_Tname & "];"
    
    'Remet les valeurs par défaut des champs
    xCount = cat.Tables(S_Tname).Columns.Count - 1
    Set TblField.ParentCatalog = cat
    For prpLoop = 0 To xCount
        TblField.Type = cat.Tables(S_Tname).Columns(prpLoop).Type
        FieldDefaultValue D_Tname, cat.Tables(S_Tname).Columns(prpLoop).Name, cat.Tables(S_Tname).Columns(prpLoop).Properties("Default").Value
    Next prpLoop
    
    'Remet les indexs
    xCount = cat.Tables(S_Tname).Indexes.Count - 1
    For prpLoop = 0 To xCount
        Set idxForeign = New ADOX.Index
        
        NomChampCle = cat.Tables(S_Tname).Indexes.Item(prpLoop).Name
        idxForeign.Name = NomChampCle
        idxForeign.Unique = cat.Tables(S_Tname).Indexes(prpLoop).Unique
        
        idxForeign.Columns.Append NomChampCle
        cat.Tables(D_Tname).Indexes.Append idxForeign
        
        Set idxForeign = Nothing
    Next prpLoop
    
    Set cat = Nothing
    Set TblField = Nothing
End Function

Public Function ADOExecute(ByVal TmpSql As String) As Boolean
On Error Resume Next
Dim bExecute As Boolean
Dim StartTime As Long

    'Ne me demande pas pourquoi
    'Mais si on execute des requetes à la file indiennes,
    'ADOCurrentDb.State à la valeur 5 et une erreur se produit
    'C'est pour le contrer.
    While ADOCurrentDb.State = 5
        DoEvents
        ADORefreshCache.RefreshCache ADOCurrentDb
    Wend

BoucleADOExecute:
On Error GoTo ErrADOExecute
    
    Call ADOCurrentDb.Execute(TmpSql, , adCmdText + adExecuteNoRecords + adAsyncExecute)
    
    'j'attend que la requete est terminée
    StartTime = timeGetTime() + 10000
    Do
        DoEvents
        ADORefreshCache.RefreshCache ADOCurrentDb
    Loop Until ADOCurrentDb.State <> adStateExecuting Or timeGetTime > StartTime
    
    bExecute = True
    
QuitADOExecute:
    ADOExecute = bExecute
    Exit Function
    
ErrADOExecute:
    If Err.Number = -2147467259 Then Resume BoucleADOExecute
    Debug.Print Err.Description, , "ADOExecute"
    
    On Error Resume Next
    bExecute = False
    Resume QuitADOExecute
    
End Function


Public Function OuvreBase(ByVal PathBase As String, ByVal pwdBase As String) As Boolean
Dim ConectBase As String
    Call CloseBase
    
On Error GoTo ErrOuvreBase
    
    ConectBase = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & PathBase & ";Jet OLEDB:Database Password=" & pwdBase '& ";Jet OLEDB:UserId=Administrateur"
   
    Set ADOCurrentDb = New ADODB.Connection
    ADOCurrentDb.CursorLocation = adUseClient
    ADOCurrentDb.ConnectionString = ConectBase
    ADOCurrentDb.Open
    Set ADORefreshCache = New JRO.JetEngine
    
    While (ADOCurrentDb.State = adStateClosed)
        DoEvents
    Wend
            
    OuvreBase = True
    Exit Function
    
ErrOuvreBase:
    OuvreBase = False
End Function

Public Sub SetFieldDefaultvalue(ByVal TableName As String, ByVal FieldName As String, ByVal DefautValue As Variant)
On Error Resume Next
Dim cat As New ADOX.Catalog
Dim ValueType As ADOX.DataTypeEnum


     While ADOCurrentDb.State = 5
        DoEvents
        ADORefreshCache.RefreshCache ADOCurrentDb
     Wend
        Set cat.ActiveConnection = ADOCurrentDb

    
    ValueType = cat.Tables(TableName).Columns(FieldName).Type
    
    If ValueType = adVarWChar Then 'chaine de caractere
        cat.Tables(TableName).Columns(FieldName).Properties("Default").value = CStr(DefautValue)
    ElseIf ValueType = adCurrency Then 'Monétaire
        cat.Tables(TableName).Columns(FieldName).Properties("Default").value = CCur(DefautValue)
    ElseIf ValueType = adBoolean Then '
        cat.Tables(TableName).Columns(FieldName).Properties("Default").value = CBool(DefautValue)
    Else
        cat.Tables(TableName).Columns(FieldName).Properties("Default").value = DefautValue
    End If
    
    Set cat = Nothing
End Sub

Public Sub CloseBase()
On Error Resume Next
    If ADOCurrentDb Is Nothing Then Exit Sub
    
    If ADOCurrentDb.State = adStateOpen Then ADOCurrentDb.Close
    Do
        DoEvents
    Loop Until ADOCurrentDb.State = adStateClosed
    
    Set ADOCurrentDb = Nothing
    Set ADORefreshCache = Nothing
End Sub