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.
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.