Cloner une table en ado

Soyez le premier à donner votre avis sur cette source.

Snippet vu 8 251 fois - Téléchargée 25 fois

Contenu du snippet

Voila une fonction pour cloner une table en ADO

Source / Exemple :


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

Conclusion :


Facilement transposable pour cloner une base entièrement

Si quelq'un sait pourquoi à un moment je trouve dans (ADODB.Connection)
ADOCurrentDb.State = 5 alors que cette valeur n'est pas dans les propriétés
ni dans l'aide.

A voir également

Ajouter un commentaire Commentaires
Messages postés
90
Date d'inscription
lundi 16 décembre 2002
Statut
Membre
Dernière intervention
1 février 2011

à m2rtech.????????

if OuvreBase(PathBase,pwdBase) then
call ClonerTable(SourcenNameBase, DestinationNameBase)
call CloseBase
end if

TOUT SIMPLEMENT !!!!!!!!

N'oublis pas d'inlure la référence FieldDefaultValue
(voir Historique du 31 juillet 2006 15:44:36)
Messages postés
239
Date d'inscription
mercredi 9 octobre 2002
Statut
Membre
Dernière intervention
20 février 2012

Bonjour,
quelle est la procédure qu'il faut lancer ?
ouvre_base ne semble pas appeler une autre procédure.

merci de donner un plus d'info à ce sujet.
Messages postés
672
Date d'inscription
mercredi 22 janvier 2003
Statut
Membre
Dernière intervention
2 juin 2016
1
Bonjour
Comment résoudre la référence FieldDefaultValue dans le code ci-dessus ? Si quelqu'un sait merci d'avance

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.