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
| Sub tstINSERTenADO()
Dim oCnS As ADODB.Connection ' Connexion Source
Dim oRsS As ADODB.Recordset ' Recordset Source
Dim oCnD As ADODB.Connection ' Connexion Destination
Dim oRsD As ADODB.Recordset ' Recordset Destination
Dim sSqlS As String, sSqlD As String
Dim lgTotEnr As Long, lgEnr As Long
Dim iChp As Integer, sNomChp As String
Dim lgLoopCnt As Long
' ** Ouverture Connexion Source **
Set oCnS = New ADODB.Connection
oCnS.CursorLocation = adUseClient
oCnS.ConnectionTimeout = 60 ' Timeout connexion 1mn
oCnS.CommandTimeout = 300 ' Timeout requête 5mn
oCnS.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
"F:\Access\tmpDB1.mdb" & ";User ID=Admin"
oCnS.Open
' ** Ouverture Connexion Destination **
' Comme c'est Access, on utilise la connexion du projet
Set oCnD = CurrentProject.Connection
' Vide table destination
oCnD.Execute "DELETE FROM tblTest2", , adCmdText
' ** Ouverture recordset sur données sources **
' Préparation recordset
Set oRsS = New ADODB.Recordset
oRsS.CursorLocation = adUseClient
oRsS.CursorType = adOpenStatic
oRsS.LockType = adLockReadOnly
Set oRsS.ActiveConnection = oCnS
sSqlS = "SELECT [ID], [Dt], [Week], " & _
"(SELECT T2.[Test] From tblTest As T2 WHERE T2.[ID] = T1.[ID]) AS test " & _
"FROM tblTest As T1"
' Ouverture asynchrone du recordset
oRsS.Open sSqlS, , , , adCmdText Or adAsyncFetch
' Boucle d'attente
Do
lgLoopCnt = lgLoopCnt + 1
If (lgLoopCnt Mod 2) = 0 Then
Me.lblStatut.Caption = "Ouverture"
Else
Me.lblStatut.Caption = "Ouverture ..."
End If
Me.Repaint
' Le DoEvents fait que Access ne fige pas
DoEvents
Loop Until (oRsS.State = adStateOpen)
' Si le recordset est vide on quitte
If oRsS.BOF And oRsS.EOF Then
GoTo Sortie
End If
' Mémoriser le nombre d'enregistrements sources
lgTotEnr = oRsS.RecordCount
' Remarque sur .RecordCount:
' Selon le provider de la connexion et/ou les paramètres du recordset
' il se peut que RecordCount retourne toujours -1
' ** Ouverture recordset sur table destination **
' Préparation recordset
Set oRsD = New ADODB.Recordset
oRsD.CursorLocation = adUseClient
oRsD.CursorType = adOpenStatic
oRsD.LockType = adLockOptimistic
Set oRsD.ActiveConnection = oCnD
sSqlD = "SELECT * FROM tblTest2"
' Ouverture recordset
oRsD.Open sSqlD, , , , adCmdText
' Boucler sur les enregistrements Source
' et les ajouter au recordset Destination
Do
' Compteur enregistrement
lgEnr = lgEnr + 1
' Ajouter un enregistrement
oRsD.AddNew
' Recopier les champs
For iChp = 0 To oRsS.Fields.Count - 1
sNomChp = oRsS.Fields(iChp).Name
oRsD.Fields(sNomChp).Value = oRsS.Fields(iChp).Value
Next
' Sauver le nouvel enregistrement
oRsD.Update
'
If (lgEnr Mod 100) = 0 Then
Me.lblStatut.Caption = "Copie (" & Round(100 * lgEnr / lgTotEnr, 0) & "%)"
DoEvents
End If
' Enregistrement Source suivant
oRsS.MoveNext
Loop Until oRsS.EOF
Sortie:
' Fermeture et libération des objets ADO
If Not (oRsD Is Nothing) Then
If oRsD.State <> adStateClosed Then oRsD.Close
End If
Set oRsD = Nothing
Set oCnD = Nothing
If Not (oRsS Is Nothing) Then
If oRsS.State <> adStateClosed Then oRsS.Close
End If
Set oRsS = Nothing
If Not (oCnS Is Nothing) Then
If oCnS.State <> adStateClosed Then oCnS.Close
End If
Set oCnS = Nothing
End Sub |
Afficher une msgbox ou une autre forme "Veuillez patienter pendant le traitement" pendant la mise à jour
Répondre avec citation
Envoyé par Domi2
, je pense qu'il n'y a pas de solution à ce petit problème.
Partager