Discussion :

[RobKris63]

Bonjour à tous,

J'ai une application Access avec des formulaires qui affichent dans un DataGrid des résultats de requêtes. Jusque là Ok

Cette appli fonctionnait sous 2003 et a été convertie en 2010.

Lorsque l'on veut appliquer un filtre dans le DataGrid, soit ce dernier ne fait rien soit j'ai les messages d'erreur:

"Impossible d'initialiser le fournisseur de données" ou alors "entrez une valeur valide".

Après pas mal de recherches sur le Net et même chez Microsoft, je n'ai pas trouvé le hic.

Si vous connaissiez ce problème de filtre et comment le résoudre, ça m'arrangerait un petit peu !

Merci

@ +++ Kris

[diki971]

peux tu donner le code ou ta le message d'erreur?

[RobKris63]

Salut Diki971,

Le message d'erreur ne s'affiche pas dans le code, mais dans une boite de dialogue dans l'appli.



Bonne journée

@ +++ Kris

[diki971]

ou le code ou il s'initialise c'est quoi?

[RobKris63]

Salut Diki971

Le load:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
 
 
Private Sub Form_Load()
    On Error GoTo err
    ' IA le 22/06/2011 : version utilisateur
    Versions = VerificationVersion()
 
    If Versions <> "" Then
        MsgBox "La " & Versions & " a été livrée, Veuillez vous reconecter, Merci ", vbExclamation, "Changement de version"
        Exit Sub
    End If
 
    'Modifier par dm le 15/03/2007 : On améliore le code et on enlève les commentaires
    'qui ne servent à rien.
 
    'Définition du périmètre et des variables Color_Font et Color_Back grace à
    'la fonction Def_perim
    'perim = Def_perim(Me.OpenArgs)
 
    'modifié par jfm le 10/07/2007
    If IsNull(Me.OpenArgs) Then
        Perim = ""
    Else
        Perim = Me.OpenArgs
    End If
 
    'rajouté par dm le 05/07/2007
    Perim = Def_perim(Perim)
 
    'rajouté par jfm le 04/07/2007 pour gérer le nouveau formulaire avec choix Asset/H.Asset et Type Dépense par bouton radio
    'par défaut on prend tout
   TypAsset = ""
    TypDepense = "S"
 
    Me.etiq_titre.ForeColor = Color_font
    Me.etiq_titre.BackColor = Color_Back
 
    Me.chx_annee_compta = Year(Now())
    Me.chx_annee_budget = Year(Now())
 
    Set Forms("F_COMMANDE").Recordset = Nothing
 
Exit_:
    Exit Sub
 
err:
    MsgBox err.Description
    Resume Exit_:
End Sub
 
'Les fonctions appelées dans le Load:
 
'IA le 22/06/2011
Public Function VerificationVersion() As String
    On Error GoTo err
 
    If Not BaseConnecter Then
        Call Connecter
    End If
 
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset
    Dim Prm1 As ADODB.Parameter
    Dim Prm2 As ADODB.Parameter
    Dim Date_Version As Date
 
    Set cmd = CreateObject("ADODB.Command")
 
    Set cmd.ActiveConnection = cnx
 
    cmd.CommandText = "..."
    cmd.CommandType = adCmdStoredProc
 
    Set Prm1 = cmd.CreateParameter("@err", adInteger, adParamOutput, 4, 0)
    Set Prm2 = cmd.CreateParameter("@lib_err", adVarChar, adParamOutput, 255)
 
   cmd.Parameters.Append Prm1
    cmd.Parameters.Append Prm2
 
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
 
    If CurrentProject.AllForms("Menu Général").IsLoaded Then
        If Not rs.EOF Then
            If rs.Fields("LIB_PARAMETRE_1") <> Forms![Menu Général].Label_version.Caption Then
                VerificationVersion = rs.Fields("LIB_PARAMETRE_1")
            Else
                VerificationVersion = ""
            End If
        End If
    End If
 
Exit_:
    Exit Function
 
err:
    MsgBox err.Description
    Resume Exit_:
End Function
 
Public Function Def_perim(ByVal arg As String) As String
'Si l'argument est vide, on va lui affecter la valeur du code périmètre
'stockée au niveau du menu général.
    On Error GoTo Err_Def_perim
 
    If arg = "" Then
        arg = RenvoiPerimetre
    End If
 
    Select Case arg
 
    Case "ICDC_M"
        Color_font = vbWhite
        Color_Back = 10259764
 
    Case "IXIS_CIB"
        Color_font = vbWhite
        Color_Back = 3873457
 
        'rajouté par jfm le 20/06/2007
    Case "NATIXIS"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "NATIXIS_DR"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "NATIXIS_SP"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "NATIXIS_AI"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "NATIXIS_SC"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "NATIXIS_ND"
        Color_font = 5577728
        Color_Back = vbWhite
 
    Case "ICDC_IS"
        Color_font = 16711680
        Color_Back = 12632256
 
    Case "CNCE"
        Color_font = 0
        Color_Back = 31476
 
    End Select
 
   'Remettre à jour la variable Libelle_Perimetre
    If Libelle_Perimetre = "" Then
        Libelle_Perimetre = RenvoiEtablissement
    End If
 
    Def_perim = arg
 
    Exit Function
 
Err_Def_perim:
 
    If err.Number > 0 Then
        Message = Message + CStr(j)
        MsgBox Message & Chr(13) & _
               "Erreur n° " & err.Number & Chr(13) & vbCr & err.Description, vbCritical, "Module_perimetre"
    End If
    'on nettoie l'objet err
    err.Clear
    Exit Function
End Function
 
' Personnellement, je ne vois rien dans ces fonctions en rapport avec ce problème
 
' Le Recordset
 
Private Function ChargeRs(ByVal annee_compta As Integer, ByVal annee_budget As Integer, ByVal top As Integer, ByVal Filtre As String)
 
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset
    Dim Prm1 As ADODB.Parameter
    Dim Prm2 As ADODB.Parameter
    Dim Prm3 As ADODB.Parameter
    Dim Prm4 As ADODB.Parameter
    Dim Prm5 As ADODB.Parameter
    Dim Prm6 As ADODB.Parameter
    Dim Prm7 As ADODB.Parameter
 
    Dim TOT_MNT_HT As Variant
    Dim TOT_MNT_HT_TVA_NR As Variant
    Dim toto As Variant
 
    On Error GoTo err
 
    TOT_MNT_HT = 0
    TOT_MNT_HT_TVA_NR = 0
 
    Set cmd = CreateObject("ADODB.Command")
 
    Set cmd.ActiveConnection = cnx
 
    cmd.CommandText = "..."
    cmd.CommandType = adCmdStoredProc
 
    Set Prm1 = cmd.CreateParameter("@entite", adVarChar, adParamInput, 10, Perim)
    Set Prm2 = cmd.CreateParameter("@annee_compta", adInteger, adParamInput, 4, annee_compta)
    Set Prm3 = cmd.CreateParameter("@annee_budget", adInteger, adParamInput, 4, annee_budget)
    Set Prm4 = cmd.CreateParameter("@top_asset", adInteger, adParamInput, 2, top)
    Set Prm5 = cmd.CreateParameter("@type_dep", adVarChar, adParamInput, 1, Filtre)
    Set Prm6 = cmd.CreateParameter("@err", adInteger, adParamOutput, 4, 0)
    Set Prm7 = cmd.CreateParameter("@lib_err", adVarChar, adParamOutput, 255)
 
    cmd.Parameters.Append Prm1
    cmd.Parameters.Append Prm2
    cmd.Parameters.Append Prm3
    cmd.Parameters.Append Prm4
    cmd.Parameters.Append Prm5
    cmd.Parameters.Append Prm6
    cmd.Parameters.Append Prm7
 
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    Set Forms("F_COMMANDE").Recordset = Nothing
 
    If Not (rs.BOF And rs.EOF) Then rs.MoveFirst
    Do While Not rs.EOF
        TOT_MNT_HT = TOT_MNT_HT + rs.Fields("MNT_HT")
        TOT_MNT_HT_TVA_NR = TOT_MNT_HT_TVA_NR + rs.Fields("MNT_HT_TVA_NR")
        rs.MoveNext
    Loop
 
    NbreLigneRs = rs.RecordCount
 
    If Me.TypeCommande.Value = 1 Then
        btn_detail_com.Visible = True
    End If
 
    If rs.RecordCount = 0 Then
        btn_detail_com.Visible = False
        C_extrac.Visible = False
    Else
        If TopASSET <> 0 Then
            '       btn_detail_com.Visible = True
            C_extrac.Visible = True
        End If
    End If
 
    Set Forms("F_COMMANDE").Recordset = rs
 
    txt_TOT_MNT_HT.Value = Format(TOT_MNT_HT, K_FMT_NUM_STD)
    txt_TOT_MNT_HT_TVA_NR.Value = Format(TOT_MNT_HT_TVA_NR, K_FMT_NUM_STD)
 
    nblignes.Caption = "(" & rs.RecordCount & " lignes)"
 
    'Pour se repositionner sur l'enregistrement qui vient d'etre modifié
    If strCurrentRecord <> "" Then
        Do While Not rs.EOF
            If rs.Fields("NUMERO_COMMANDE") = strCurrentRecord Then
                Me.Bookmark = rs.Bookmark
                Exit Do
            End If
            rs.MoveNext
        Loop
    End If
 
    If Left(Perim, 7) = "NATIXIS" Then
        E_Famille_Presta_Budget.Visible = True
        FAMILLE_DE_PRESTA_BUDGET.Visible = True
    Else
        E_Famille_Presta_Budget.Visible = False
        FAMILLE_DE_PRESTA_BUDGET.Visible = False
    End If
 
    'rajouter le 28/11/2006
    Call GestionBouton
 
    Set rs = Nothing
    Set cmd = Nothing
 
    Exit Function
 
Exit_:
    Exit Function
 
err:
    MsgBox err.Description
    Resume Exit_:
 
End Function

J'ai par ailleurs bien vérifié que la propriété "Filtrage autorisé" du formulaire en question soit "F_COMMANDE" était à "OUI"

Bonne journée

@ +++ Kris

[diki971]

"aramis" correspond a quoi?
et j'ai quelque qui peut t'interressé mais c'est pas moi qui la créé le code
mais ca peut t'etre utile

[RobKris63]

Salut Diki971,

En fait "Aramis" ne correspond à rien de spécial, c'ets simplement un titre donné par le créateur de l'appli.

Ton code peut-être interessant pour ma connaissance, car dans le cas présent, il y a plusieurs formulaires qui souffrent du même problème et le but était d'avoir une solution applicable sur l'ensemble de l'appli.

Merci à toi et bonne journée.


@ +++ Kris

[diki971]

dans un module de classe
Code class ADODBRD :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
 
 
Private Connexion
Public TYPEBASE
Public BASE
Public Server
Public Fichier
Public User
Public Password
 
Private Function GenereCSTRING()
'Permet de générer le Cornec String
'1 - ODBC
'2 - ORACLE
'3 - ACCESS 2012
'4 - ACCESS 2000
'5 - ACCESS 97
'6 - SQL SERVER
'7 - SQL SERVER 2005 Express
'9 - SQLite
'10 - SQLite3
If Trim("" & Fichier) = "" Then Fichier = BASE
 
Select Case TYPEBASE
    Case 1
        GenereCSTRING = "Provider=MSDASQL.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
    Case 2
        GenereCSTRING = "Provider=OraOLEDB.Oracle.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
 
    Case 3
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fichier & ";"
 
    Case 4
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & ";Persist Security Info=False"
    Case 5
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & Fichier
    Case 6
            GenereCSTRING = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & Fichier
           ' GenereCSTRING = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & Fichier & ";user=" & User & ";Passwors=" & PassWord
    Case 7
        GenereCSTRING = "Provider=SQLOLEDB.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & BASE & ";Data Source=" & Server
    Case 8
        GenereCSTRING = "Provider=SQLNCLI.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & BASE & ";Data Source=" & Server
    Case 9
        GenereCSTRING = "Provider=OleSQLite.SQLiteSource.3; Data Source=" & Fichier
 
        GenereCSTRING = "Driver={SQLite ODBC (UTF-8) Driver};Database=" & Fichier & ";StepAPI=;Timeout="
    Case 10
        GenereCSTRING = "Driver={SQLite3 ODBC Driver};Database=" & Fichier & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
    Case Else
        GenereCSTRING = "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
 
 
End Select
''MsgBox GenereCSTRING
'Response.End
End Function
 
 
Public Function OpenConnetion()
'Ouvre une connexion à  la base de données.
'Dim Fso As New Scripting.FileSystemObject
    OpenConnetion = False
    On Error Resume Next
    Dim ConnecString
 
     Dim NbErr
 
    Set Connexion = CreateObject("ADODB.Connection")
    Connexion.Open GenereCSTRING
'ConnecString
 
    If Err = 0 Then
 
        OpenConnetion = True
       Connexion.CommandTimeout = 14400
    Else
  ''MsgBox Err.Description
 
    End If
'    Debug.Print Err.Description
    Err.Clear
    On Error GoTo 0
End Function
 
 
Public Function CloseConnection()
'Referme la connexion
CloseConnection = False
On Error Resume Next
    Connexion.Close
    Set Connexion = Nothing
     If Err = 0 Then
        CloseConnection = True
    End If
    Err.Clear
    On Error GoTo 0
End Function
 
 
Public Function OpenRecordSet(Sql)
'Retourne un RecordeSet
On Error Resume Next
    Dim RS
Dim NbErr
 
Err.Clear
If Connexion.State = 0 Then
    OpenConnetion
End If
'Debug.Print Sql 'Replace(Sql, "%", "*")
    Set OpenRecordSet = CreateObject("ADODB.Recordset")
 
   ' OpenRecordSet.LockType = adLockOptimistic
    ''MsgBox  adLockOptimistic & vbcrlf & Err.Description
    OpenRecordSet.Open Sql, Connexion, 1, 3
 
    If Err Then
   ' 'MsgBox  Err.Description
 
    NbErr = NbErr + 1
        If NbErr < 11 Then
 
            Set OpenRecordSet = Nothing
 
 
        End If
 
    End If
    Err.Clear
 
End Function
Public Function RetournConnection()
Set RetournConnection = Connexion
End Function
Public Function OpenRecordSetParametre(Sql, Param)
Dim Commande
Dim Params
Set Commande = CreateObject("ADODB.Command")
Dim MyParameter
Set MyParameter = CreateObject("ADODB.Parameter")
Set Commande.ActiveConnection = Connexion
Commande.CommandText = "select Requête2.* from Requête2;"
 Commande.CommandType = adCmdText
 
 Set MyParameter = Commande.CreateParameter("[NumJob]", adNumeric)
         MyParameter.Value = 10
Commande.Parameters.Append MyParameter
 
 
 
'aa.Parameters.Append("MyRef") = "243410M660"
Set Rs2 = Commande.Execute
 
End Function
Public Function CloseRecordSet(RS)
On Error Resume Next
    RS.Close
    Set CloseRecordSet = Nothing
End Function
Public Function Execute(Sql)
    Execute = False
    On Error Resume Next
    Dim NbErr
Reprise:
If Connexion.State = 0 Then
    OpenConnetion
End If
Debug.Print Sql
    Connexion.Execute Sql
    If Err = 0 Then
        Execute = True
 
 
 
 
'     Else
'    'MsgBox Err.Description
'         Err.Clear
'    NbErr = NbErr + 1
'    If NbErr < 11 Then
'
'        GoTo Reprise
'    End If
Else
    'MsgBox Err.Description
    End If
 
    Err.Clear
 
End Function

dans un module classique:
Code module:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub test()
Dim db As String
Dim wb As Workbook
Dim t As New clsTdcRD
 
Dim con As New ADODBRD
Dim Sql As String
Dim I As Integer
Dim Rec
Dim Rep As String
Rep = ActiveWorkbook.Path
con.TYPEBASE = 4
con.Fichier = Rep & "\Test-ADODBRD.mdb"
Sql = "SELECT NomPrenomAge.* FROM NomPrenomAge;"
Set Rec = con.OpenRecordSet(Sql)
 
Dim wrk As Workbook
Set wrk = Application.Workbooks.Add
 
'insert les en-tetes
For I = 1 To Rec.Fields.Count
    wrk.Sheets(1).Cells(1, I).Value = Rec.Fields(I - 1).Name
Next I
 
'Ajout des données à partir de A2
wrk.Sheets(1).Range("A2").CopyFromRecordset Rec
 End Sub

ce code a été créé par rdurupt
http://www.developpez.net/forums/u503269/rdurupt/

[Invité]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
'Permet de générer le Cornec String
'1 - ODBC
'2 - ORACLE
'3 - ACCESS 2012
'4 - ACCESS 2000 Microsoft.Jet.OLEDB.4.0
'5 - ACCESS 97
'6 - SQL SERVER
'7 - SQL SERVER 2005 Express
'9 - SQLite
'10 - SQLite3
con.TYPEBASE = 4

correspondent au driver installés sur t'a machine ce que de toute déviance n'est pas le cas. je pense que le problème est là
test avec ACCES 2012