Module de classe type et surcharge

Version imprimable

Bonjour à tous,

Je me remets au vba après un an de pause à faire du js/php, j'avais donc pris la bonne habitude de faire de la POO. Ceci devient pourtant très fastidieux en vba...

Du coup je créé une grosse classe abstraite avec plein de types à l'intérieur et j'ai notamment un array de chaque type que je dois souvent manipuler (ajout, update, suppression, tri, filtre etc...)
J'ai donc créé des fonctions pour manipuler les array facilement malheureusement je n'ai pas trouver comment surcharger une fonction car les types utilisateurs ne peuvent pas être convertis en variant...

Exemple :
Code:

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 Type tField attr1 As String attr2 As Date End Type Type tTable attr1 As String attr2 As Date End Type Sub main() Dim arrFields() As tField Dim field As tField Dim arrTables() As tTable Dim table As tTable field.attr1 = "test" field.attr2 = Date table.attr1 = "test" table.attr2 = Date arrPush arrFields, field arrPush arrTables, table End Sub Private Sub arrPush(arr, el) If isErasedArray(arr) Then ReDim arr(1) Else ReDim Preserve arr(UBound(arr) + 1) End If arr(UBound(arr)) = el End Sub Private Function isErasedArray(arr) As Boolean Dim a& On Error GoTo ieaError a = UBound(arr) isErasedArray = False Exit Function ieaError: isErasedArray = True End Function
Je me retrouve avec le message d'erreur

Citation:

"Erreur de compilation: Seuls les types définis par l'utilisateur et qui sont définis dans les modules d'objets publics peuvent être convertis depuis ou vers un variant, ou passés à des fonctions à liaison tardive"

Pour l'instant la solution est de faire :
Code:

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 Option Explicit Option Base 1 Type tField attr1 As String attr2 As Date End Type Type tTable attr1 As String attr2 As Date End Type Sub main() Dim arrFields() As tField Dim field As tField Dim arrTables() As tTable Dim table As tTable field.attr1 = "test" field.attr2 = Date table.attr1 = "test" table.attr2 = Date arrPushField arrFields, field arrPushTable arrTables, table End Sub Private Sub arrPushField(arr() As tField, el As tField) If isErasedArrayField(arr) Then ReDim arr(1) Else ReDim Preserve arr(UBound(arr) + 1) End If arr(UBound(arr)) = el End Sub Private Sub arrPushTable(arr() As tTable, el As tTable) If isErasedArrayTable(arr) Then ReDim arr(1) Else ReDim Preserve arr(UBound(arr) + 1) End If arr(UBound(arr)) = el End Sub Private Function isErasedArrayField(arr() As tField) As Boolean Dim a& On Error GoTo ieaError a = UBound(arr) isErasedArrayField = False Exit Function ieaError: isErasedArrayField = True End Function Private Function isErasedArrayTable(arr() As tTable) As Boolean Dim a& On Error GoTo ieaError a = UBound(arr) isErasedArrayTable = False Exit Function ieaError: isErasedArrayTable = True End Function
Mais ça va vite devenir très lourd... Là je n'ai que deux fonctions mais je risque d'en avoir un paquet...

Quelqu'un a-t-il une astuce pour surcharger les fonctions en vba ?

PS : sachant que je ne créé pas un module de classe par type parce que ça devient vite très lourd également (voir pire) et je ne suis pas sûr de résoudre le problème.

bonjour,
tu as 2 option!
tu peux passer en paramètres un objet ParamArray dan ce cas tu dois scanner le tableau V et scanner les tableau a,b,c,d en n’oubliant pas d'identifier le type de données

Code:

TypeName(MyVariable(1))

soit utiliser de paramètre Optionnels!
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Sub test(ParamArray V() As Variant) End Sub Sub test2(Optional a, Optional b, Optional c, Optional d) End Sub Sub test3() test Array(1, 2, 3, 4), Array(4, 5, 6), Array(7, 8, 9), "toto" test2 a:=1, b:=2, c:=3, d:=4 test2 a:=1, b:=2 End Sub

31/03/2016, 14h07
cerede2000

Bonjour à toi,

Malheureusement à part Variant pas de surcharge en VBA.....
31/03/2016, 14h09
Philippe PONS

Salut,

en VBA, c'est de la POO très réduite.
Pas de surcharge, ni d'interface, ni d'héritage, etc...

Citation:

Bonjour à toi,

Malheureusement à part Variant pas de surcharge en VBA.....

Citation:

Salut,

en VBA, c'est de la POO très réduite.
Pas de surcharge, ni d'interface, ni d'héritage, etc...

Mais pourquoi l'une des plus puissantes société du monde nous inflige ça ?
Ils ont le droit de faire évoluer vba comme php l'a fait par exemple...

Rdurupt : pensais-tu à quelque chose comme ça ?
Code:

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 Sub main() Dim arrFields() As tField Dim field As tField Dim arrTables() As tTable Dim table As tTable field.attr1 = "test" field.attr2 = Date table.attr1 = "test" table.attr2 = Date arrPush arrFields, field arrPush arrTables, table End Sub Private Sub arrPush(ParamArray arr()) Dim arrTmp(), i& If isErasedArray(arr(0)) Then ReDim arrTmp(1) arr(0) = arrTmp Else ReDim arrTmp(UBound(arr(0)) + 1) For i = 1 To UBound(arr(0)) arrTmp(i) = arr(0)(i) Next i End If arrTmp(UBound(arrTmp)) = arr(1) arr(0) = arrTmp End Sub Private Function isErasedArray(ParamArray arr()) As Boolean Dim a& On Error GoTo ieaError a = UBound(arr(0)) isErasedArray = False Exit Function ieaError: isErasedArray = True End Function
Car j'ai le même message d'erreur :

Citation:

"Erreur de compilation: Seuls les types définis par l'utilisateur et qui sont définis dans les modules d'objets publics peuvent être convertis depuis ou vers un variant, ou passés à des fonctions à liaison tardive"

31/03/2016, 16h04
cerede2000

Je suis totalement d'accord avec toi et j'aurais même bien vu un virage de VBA vers C# .net !
Tout en gardant la possibilité pour rétrocompatbilité de faire du VBA mais donner le choix de classeur nouvelle génération avec un vrai langage des années 2010...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
For i =0 to ubound(arr)
   if typenme(arr(i)) ="array"  then
      for x = 0 to ubound(arr(i))
        msgbox arr(i)(x)
      next
   end if
 
if typenme(arr(i)) ="range"  then
      for x = 1 to arr(i).cells.count
 
        msgbox arr(i)(x)
      next
   end if
Next

31/03/2016, 16h32
mathspountz

Merci Rdurupt mais le problème ne vient pas de la manière de traiter les arguments contenus dans ParamArray mais d'une erreur de compilation donc je ne peux même pas lancer le code.
Le problème vient bien de l'appel de la fonction et non de la fonction elle même...

Une fois cette erreur contournée, je pense pouvoir me débrouiller pour traité mes données en fonction de leur type.
31/03/2016, 16h37
Invité

Il faut absolument typer en variant même si paradoxalement les variables non typer son de variant!
ParamArray arr() as varaintÉdite: Nom pas besoin de typer:
http://www.developpez.net/forums/d14...a/#post7804210

Je viens d comprendre le problème

A l'intérieur d'un module de classe la définition des types ne peuvent être que privé! Ce qui t'interdit d'utiliser ce le type en question à extérieur du module!

Soit il n'est utile que dans le module et tu le défini en privé, ou tu le défini en public dans un module standard!

On est effectivement bien loin du .net alors on compose!
01/04/2016, 09h55
mathspountz

Bon j'abandonne je vais faire mon programme en procédurale dégueulasse, ensuite je démissionne et je cherche un boulot dans le Web XD

Merci à tous pour vos réponses !
01/04/2016, 09h58
cerede2000

:ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr:
Et la ton chez passe par ce forum, il reconnait le code que t'est en train de faire pour lui et te convoque dans son bureau :mouarf:
01/04/2016, 10h02
Invité

1 pièce(s) jointe(s)

Bonjour,
pourquoi tu ne développerais pas ton programme en .net, et les utilisateur manipulerais ton fichier xls dans ton .exe?

ou ça (références Excel) mais j'ai jamais testé!
Pièce jointe 205559

de toutes les façons vba dispose que de notion de classe (embryonnaire) , il méritait de devenir un grand langage! mais la réputation de langage instinctif pour développeur spaghettis du dimanche, initié par Microsoft lui même, l'a complètement discrédité!

En revanche tu peut définir un autre module de classe et ne lui affecté que de le propriétés Property ou variable public et l'utiliser comme un type!

Et ce ClsType passera sen problème dans tes méthodes!
01/04/2016, 10h24
mathspountz

C'est tentant mais je ne connais pas bien .NET ni visual studio après ça serait justement l'occasion de m'y mettre mais bon..

Etape 1) Faire copain copain avec un mec du support pour qu'il m'installe visual studio (express) (car je ne suis pas admin de mon poste)
Etape 2) Apprendre le C# (j'avais fais le tuto à l'époque mais ça s'oublie vite quand tu n'utilises pas)
Etape 3) Quand je m'en vais, j'explique à mon chef que pour me remplacer il va falloir qu'il trouve un dev .NET (= + cher !) parce que j'ai pris des initiatives XD

Sinon à la base je voulais créer un mini BO (Business Object) qui permette à des utilisateurs ne connaissant pas SQL de requêter plusieurs fichiers Excel/csv voir base access (on verra pour la V2) stockés dans un réseau partagé avec jointures etc, via une interface simple.

C'est pour ça que je voudrais bien le ficeler en POO plutôt qu'en procédurale.

En attendant je vais faire des recherche sur manipulation d'ADODB en C# on sait jamais ça se trouve c'est facile !
01/04/2016, 10h30
cerede2000

Ouaou !
Beau projet !
Mais à mon avis en VBA Excel........
Et il te faudra quand même un peu de temps, un QueryBuilder ne se fait pas en 3 coup de cuillère à pot ;)

Code:

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
 
 
Private Connexion
Public TYPEBASE As MyAdo
Public BASE
Public Server
Public Fichier
Public User
Public PassWord
Enum MyAdo
 ACCESS97 = 1
ACCESS2000 = 2
ACCESS2012 = 1
ODBC = 4
ORACLE = 5
 SQLSERVER2005 = 6
SQLServer2008R2 = 7
SQLite = 8
SQLite3 = 9
CSV = 10
ExcelSensTire = 11
ExcelAvecTire
End Enum
 
Private Function GenereCSTRING()
'Permet de générer le Cornec String
'1 - ACCESS 97
'2 - ACCESS 2000
'3 - ACCESS 2012
'4 - ODBC
'5 - ORACLE
'6 - SQL SERVER 2005
'7 - SQL Server 2008 R2
'8 - SQLite
'9 - SQLite3
If Trim("" & Fichier) = "" Then Fichier = BASE
 
Select Case TYPEBASE
    Case ExcelAvecTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    Case ExcelSensTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=no;"""
    Case ACCESS97
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & Fichier
    Case ACCESS2000
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & ";Persist Security Info=False"
    Case ACCESS2012
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fichier & ";"
 
    Case ODBC
        GenereCSTRING = "Provider=MSDASQL.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
    Case ORACLE
        GenereCSTRING = "Provider=OraOLEDB.Oracle.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
    Case SQLSERVER2005
        GenereCSTRING = "Provider=SQLOLEDB.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & BASE & ";Data Source=" & Server
    Case SQLServer2008R2
        GenereCSTRING = "Provider=SQLNCLI;Server=" & Server & ";Database=" & BASE & ";UID=" & User & ";PWD=" & PassWord & ";"
    Case SQLite
        GenereCSTRING = "Provider=OleSQLite.SQLiteSource.3; Data Source=" & Fichier
        GenereCSTRING = "Driver={SQLite ODBC (UTF-8) Driver};Database=" & Fichier & ";StepAPI=;Timeout="
    Case SQLite3
        GenereCSTRING = "Driver={SQLite3 ODBC Driver};Database=" & Fichier & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
    Case CSV
        GenereCSTRING = "ODBC;DBQ=" & Fichier & ";Driver={Microsoft Text Driver (*.txt; *.csv)}; " & "DriverId=27;Extensions=txt,csv,tab,asc;FIL=text;MaxBufferS"
    Connex.Open
    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

Code:

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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
 
Imports System.Data
Imports NDbUnit.Core.SqlLite
Imports System.Runtime.InteropServices
Public Class ClsAdodbRd
    Public Structure ParmCmd
        Public Name As String
        Public Type As VarAdodb
        Public Direction As VarAdodb
        Public Size As Long
        Public Value As String
    End Structure
    Public Enum VarAdodb
        adAddNew = 16778240
        adAffectAllChapters = 4
        adAffectCurrent = 1
        adAffectGroup = 2
        adApproxPosition = 16384
        adArray = 8192
        adAsyncConnect = 16
        adAsyncExecute = 16
        adAsyncFetch = 32
        adAsyncFetchNonBlocking = 64
        adBigInt = 20
        adBinary = 128
        adBookmark = 8192
        adBookmarkCurrent = 0
        adBookmarkFirst = 1
        adBookmarkLast = 2
        adBoolean = 11
        adBSTR = 8
        adChapter = 136
        adChar = 129
        adClipString = 2
        adCmdFile = 256
        adCmdStoredProc = 4
        adCmdTable = 2
        adCmdTableDirect = 256
        adCmdText = 1
        adCmdUnknown = 8
        adCollectionRecord = 1
        adCompareEqual = 1
        adCompareGreaterThan = 2
        adCompareLessThan = 0
        adCompareNotComparable = 4
        adCompareNotEqual = 3
        adCopyAllowEmulation = 4
        adCopyNonRecursive = 2
        adCopyOverWrite = 1
        adCopyUnspecified = -1
        adCreateCollection = 8192
        adCreateNonCollection = 0
        adCreateOverwrite = 67108864
        adCreateStructDoc = -2147483648
        adCriteriaAllCols = 1
        adCriteriaKey = 0
        adCriteriaTimeStamp = 3
        adCriteriaUpdCols = 2
        adCRLF = -1
        adCurrency = 6
        adDate = 7
        adDBDate = 133
        adDBTime = 134
        adDBTimeStamp = 135
        adDecimal = 14
        adDefaultStream = -1
        adDelayFetchFields = 32768
        adDelete = 16779264
        adDouble = 5
        adEditAdd = 2
        adEditDelete = 4
        adEditInProgress = 1
        adEditNone = 0
        adEmpty = 0
        adErrBoundToCommand = 3707
        adErrCannotComplete = 3732
        adErrCantChangeConnection = 3748
        adVarChar = 200
        adParamInput = 1
    End Enum
    Public Enum CommAdo
        adCmdFile = 256
        adCmdStoredProc = 4
        adCmdTable = 2
        adCmdTableDirect = 521
        adCmdText = 1
        adCmdU
        nknown = 8
    End Enum
 
    'Public Enum MyAdo
    '    ACCESS97 = 1
    '    ACCESS2000 = 2
    '    ACCESS2012 = 13
    '    ODBC = 4
    '    ORACLE = 5
    '    SQLSERVER_NT4 = 12
    '    SQLSERVER2005 = 6
    '    SQLServer2008R2 = 7
    '    SQLite = 8
    '    SQLite3 = 9
    '    CSV = 10
    '    Excel8 = 11
    'End Enum
    Private _Cn As Object = Nothing
    Private TYPEBASE As MyAdo
    Private BASE As String = ""
    Private MonServer As String = ""
    Private MonUser As String = ""
    Private MonPassword As String = ""
    Private DirecCn As Boolean = False
    Public Property ConnexionDirect As Boolean
        Set(ByVal value As Boolean)
            DirecCn = value
            If value = False Then CloseConnection() Else OpenConnetion()
        End Set
        Get
            Return DirecCn
        End Get
    End Property
    Public ReadOnly Property Status As Boolean
        Get
            Try
                Return _Cn.State
            Catch ex As Exception
                Return False
            End Try
        End Get
    End Property
 
 
    Public Property ConectString As Object
        Get
            Return GenereCSTRING()
        End Get
        Set(ByVal value As Object)
 
        End Set
    End Property
    Public ReadOnly Property Connexion As AdoDbRd
        Get
            Return _Cn
        End Get
        'Set(ByVal value As Object)
 
        'End Set
    End Property
 
    Public Property Password As String
        Get
            Return MonPassword
        End Get
        Set(ByVal value As String)
            MonPassword = value
        End Set
    End Property
    Public Property User As String
        Get
            Return MonUser
        End Get
        Set(ByVal value As String)
            MonUser = value
        End Set
    End Property
    Public Property Server As String
        Get
            Return MonServer
        End Get
        Set(ByVal value As String)
            MonServer = value
        End Set
    End Property
    Public Property Database As String
        Get
            Return BASE
        End Get
        Set(ByVal value As String)
            BASE = value
        End Set
    End Property
 
    Public Property BASETYPE As MyAdo
        Get
            Return TYPEBASE
        End Get
        Set(ByVal value As MyAdo)
            TYPEBASE = value
        End Set
    End Property
    Public Sub New()
        TYPEBASE = New MyAdo
    End Sub
    Private Function GenereCSTRING() As String
 
        Select Case TYPEBASE
            Case MyAdo.ACCESS97
                Return "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & BASE
            Case MyAdo.ACCESS2000
                Return "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & BASE & ";Persist Security Info=False"
            Case MyAdo.ACCESS2012
                Return "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";"
            Case MyAdo.ODBC
                Return "Provider=MSDASQL.1;Password=" & MonPassword & ";Persist Security Info=True;User ID=" & MonUser & ";Data Source=" & BASE
            Case MyAdo.ORACLE
                Return "Provider=OraOLEDB.Oracle.1;Password=" & MonPassword & ";Persist Security Info=True;User ID=" & MonUser & ";Data Source=" & BASE
            Case MyAdo.SQLSERVER_NT4
                Return "Provider=SQLOLEDB.1;Password=" & MonPassword & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & BASE & ";Data Source=" & MonServer
            Case MyAdo.SQLSERVER2005
                Return "Provider=SQLOLEDB.1;Password=" & MonPassword & ";Persist Security Info=True;User ID=" & MonUser & ";Initial Catalog=" & BASE & ";Data Source=" & MonServer
            Case MyAdo.SQLServer2008R2
                Return "Provider=SQLNCLI;Server=" & MonServer & ";Database=" & BASE & ";UID=" & MonUser & ";PWD=" & MonPassword & ";"
            Case MyAdo.SQLite
                Return "Provider=OleSQLite.SQLiteSource.3; Data Source=" & BASE
                Return "Driver={SQLite ODBC (UTF-8) Driver};Database=" & BASE & ";StepAPI=;Timeout="
            Case MyAdo.SQLite3
                Return "Driver={SQLite3 ODBC Driver};Database=" & BASE & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
            Case MyAdo.CSV
                Return "ODBC;DBQ=" & Server & ";Driver={Microsoft Text Driver (*.txt; *.csv)}; " & "DriverId=27;Extensions=txt,csv,tab,asc;FIL=text;MaxBufferS"
            Case MyAdo.Excel8
                Return "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & BASE & ";Extended Properties=Excel 8.0;"
            Case Else
                Return "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
 
        End Select
    End Function
    Public Function RetournRep()
        Dim t() As String = BASE.Split("\")
        Return BASE.Replace(t(t.Count), "")
    End Function
    Public Function RetournFichier()
        Dim t() As String = BASE.Split("\")
        Return t(t.Count)
    End Function
    Private Function OpenConnetion() As Boolean
        'Ouvre une connexion à  la base de données.
        _Cn = GetObject("ADODB.Connection")
        _Cn.CommandTimeout = 0.000001
        Try
            _Cn.Open(GenereCSTRING) 'ConnecString
        Catch ex As Exception
            Return False
        End Try
        _Cn.CommandTimeout = 14400
        Return True
    End Function
    Private Function CloseConnection() As Boolean
        'Referme la cn
        Try
            _Cn.Close()            
        Catch ex As Exception
            Return False
        End Try
        CloseConnection = False
        _Cn = Nothing
        Return True
    End Function
    Public Function OpenRecordSet(ByVal Sql) As Object
        Dim RS As Object = Nothing
        'Retourne un RecordeSett
        Dim myObject As New Object
        Dim myCheck As Boolean
        myCheck = myObject Is _Cn.State
        If myCheck = False Then
            If OpenConnetion() = False Then Return Nothing
        End If
        RS = CreateObject("ADODB.Recordset")
        Try
            RS.Open(Sql, _Cn, 1, 3)
            Return RS
        Catch ex As Exception
            Return Nothing
        End Try
        Return RS
    End Function
 
    'Cloture le RecordSet
    Public Function CloseRecordSet(ByVal RS)
        On Error Resume Next
        RS.Close()
        CloseRecordSet = Nothing
        On Error GoTo 0
    End Function
    'Pour les requêtes directe
    Public Function Execute(ByVal Sql) As Boolean
        Dim myObject As New Object
        Dim myCheck As Boolean
        myCheck = myObject Is _Cn.State
        If myCheck = False Then
            If OpenConnetion() = False Then Return False
        End If
        Try
            _Cn.Execute(Sql)
        Catch ex As Exception
            Return False
        End Try
        Return True
    End Function
 
    Public Function OpenCommande(ByVal Sql As String, ByVal Param() As ParmCmd, ByVal CmType As CommAdo) As Object
        Dim myObject As New Object
        Dim myCheck As Boolean
        myCheck = myObject Is _Cn.State
        If myCheck = False Then
            If OpenConnetion() = False Then Return Nothing
        End If
        Dim sCmd As Object = CreateObject("Adodb.Command")
        Dim sParam As Object = Nothing
        sCmd.CommandType = CmType
        sCmd.ActiveConnection = _Cn
        sCmd.CommandText = Sql
        For i = 0 To Param.Count - 1
            sParam = sCmd.CreateParameter(Param(i).Name, Param(i).Type, Param(i).Direction, Param(i).Size, Param(i).Value)
            sCmd.Parameters.Append(sParam)
        Next
 
        Return sCmd.Execute()
    End Function
    Public Function OpenCommandeRecordSet(ByVal Sql As String, ByVal Param() As ParmCmd, ByVal CmType As CommAdo) As Object
        Dim myObject As New Object
        Dim myCheck As Boolean
        myCheck = myObject Is _Cn.State
        If myCheck = False Then
            If OpenConnetion() = False Then Return Nothing
        End If
        Dim sCmd As Object = CreateObject("ADODB.Command")
        Dim sParam As Object = Nothing
        sCmd.CommandType = CmType
        sCmd.ActiveConnection = _Cn
        sCmd.CommandText = Sql
        For i = 0 To Param.Count - 1
            If Param(i).Size <> 0 Then
                'Durupt
                sParam = sCmd.CreateParameter(Param(i).Name, Param(i).Type, Param(i).Direction, Param(i).Size, Param(i).Value)
                sCmd.Parameters.Append(sParam)
            End If
        Next
 
        Dim RstRecordSet = CreateObject("ADODB.Recordset")
        Try
            With RstRecordSet
                .CursorType = 3
                .CursorLocation = 3
                .LockType = 3
                .Open(sCmd)
            End With
        Catch ex As Exception
            Return Nothing
        End Try
 
        Return RstRecordSet
    End Function
    Public Function OpenCommandDataSet(ByVal Sql As String, ByVal Param() As ParmCmd, ByVal CmType As CommAdo, ByVal Name As String) As Object
         Dim myObject As New Object
        Dim myCheck As Boolean
        myCheck = myObject Is _Cn.State
        If OpenConnetion() = False Then Return Nothing
 
        Dim da As New System.Data.OleDb.OleDbDataAdapter()
        Dim ds As New DataSet()
        Dim Rs As Object = OpenCommandeRecordSet(Sql, Param, CmType)
        da.Fill(ds, Rs, Name)
        Return ds
    End Function
 
 
    Private Function CreateObject(ByVal app As String) As Object
        Dim AppType As Object = Type.GetTypeFromProgID(app)
        Dim ApplInst As Object = Activator.CreateInstance(AppType)
        Return ApplInst
    End Function
    Public Function GetObject(ByVal App As String) As Object
        Try
            Return Marshal.GetActiveObject(App)
        Catch ex As Exception
            Return CreateObject(App)
        End Try
 
    End Function
 
 
End Class

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Public Module VariableGlobal
    Public Enum MyAdo
        ACCESS97 = 1
        ACCESS2000 = 2
        ACCESS2012 = 13
        ODBC = 4
        ORACLE = 5
        SQLSERVER_NT4 = 12
        SQLSERVER2005 = 6
        SQLServer2008R2 = 7
        SQLite = 8
        SQLite3 = 9
        CSV = 10
        Excel8 = 11
    End Enum
    Friend Con As ClsAdodbRd
End Module

01/04/2016, 10h37
cerede2000

@rdurupt : Classe cette class !!
Je met de côté :mrgreen:
01/04/2016, 10h42
mathspountz

Bien d'accord ça peut faire gagner du temps merci beaucoup !

Sinon j'ai déjà fais un outil similaire en php/js, il tapait dans une base mySql + x fichiers csv fourni par le user donc j'ai déjà en tête toute l'archi ça devrait pouvoir se faire.

Si j'y arrive je posterai dans contribution ;)

il faut noté que dans la version vb.net j'ai implémenté la méthode créateObject et getobject via marshal et intérop car ça n'existe pas dans .net .

je pense que ma classe adodb la récupère par héritage mais je n'en suis plus sur!

Edite: non c'est dans la classe

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
 Private Function CreateObject(ByVal app As String) As Object
        Dim AppType As Object = Type.GetTypeFromProgID(app)
        Dim ApplInst As Object = Activator.CreateInstance(AppType)
        Return ApplInst
    End Function
    Public Function GetObject(ByVal App As String) As Object
        Try
            Return Marshal.GetActiveObject(App)
        Catch ex As Exception
            Return CreateObject(App)
        End Try
 
    End Function

01/04/2016, 11h07
cerede2000

@rdurupt : Par contre en .Net... Utilisé ADODB.Command je pense que ce n'est pas le top, il existe des classe .Net plus optimisé quand même.
Mais certes ça demandera plus de code !
01/04/2016, 11h15
Invité

Adodb d'une manière générale est à proscrire en .net!

oui mais les objet sont plus spécialisé et je travail sur différant type de base!

le polymorphisme je connais mais ça urgeait!

pour répondre à notre amis la surcharge je connais mais c'est pondérale! :yaisse2: