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
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
| Attribute VB_Name = "SQL"
'**************************************************************************************************
' NAME : SQL (MODULE)
' FILENAME : SQL.bas
' AUTHOR : John Mc Eevee
' VERSION : 0.1
' DESCRIPTION : Le module a pour objectif de réaliser des requêtes SQL à partir d'un jeu de donnée.
'
' PROPERTY :
'
' - PathFile (String) : Chemin d'accès du fichier texte contenant la requête SQL
' - DataBase (String) : Chemin d'accès à la base de donnée
' - Provider (Srting) : Identifiant du fournisseur d'accès à la base de donnée
' - Server (String) : Chemin d'accès au server (IP si distant sinon localhost)
' - Driver (String) : Identifiant du disque où se trouve la base de donnée
' - User (String) : Identifiant de l'utilisateur
' - Password (String) : Mot de passe de l'utilisateur
'
' FUNCTION :
'
' - ConnectToAccess (ADODB.Connection) : Connection à une base de donnée Access
' - ConnectToServer (ADODB.Connection) : Connection à un autre SGBD (Non testé)
' - AddNew (Variant) : Exécute une requete SQL et retourne un jeu de donnée ou une information
' - CreateBase (String) : Requete pour créer une base (Non testé)
' - CreateTable (String) : Requete pour créer une table (Non testé)
' - SQLInsert (String) : Requete pour inserer un jeu de données
' - SQLSelect (String) : Requete pour selectionner un jeu de données
' - SQLUpdate (String) : Requete pour mettre à jour un jeu de données (non testé)
' - SQLDelete (String) : Requete pour supprimer un jeu de données (non testé)
' - SQLWhere (String) : Requete pour faire des conditions
' - SQLJoin (String) : Requete pour faire des jointures (non testé)
' - SQLOrderBy (String) : Requete pour trier le jeu de données (non testé)
' - SQLGroupBy (String) : Requete pour grouper le jeu de données (non testé)
' - ReadFile (String) : Fonction permettant de lire un fichier texte
' - FormatValue (String) : Fonction permettant de mettre en forme les données pour les requêtes
'
' DEPANDANCE :
' - Microsoft Active X Data object 2.x Library
' - Microsoft Scripting Runtime
'**************************************************************************************************
Option Explicit
Option Base 0
Private Const MODULE_NAME As String = "SQL"
'**************************************************************************************************
' VARIABLES
'**************************************************************************************************
Public Enum ConnectionString
Access = 0
SQLServer
SQLLite
Base
End Enum
Private Type SQL_Module
Item As Variant
Key As Variant
PathFile As String
Database As String
Provider As String
Server As String
Driver As String
User As String
Password As String
End Type
Private This As SQL_Module
'**************************************************************************************************
' PROPERTY
'**************************************************************************************************
'**************************************************************************************************
' NAME : PathFile (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let PathFile(sPathFile As String)
This.PathFile = sPathFile
End Property
Public Property Get PathFile() As String
PathFile = This.PathFile
End Property
'**************************************************************************************************
' NAME : Database (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let Database(sDatabase As String)
This.Database = sDatabase
End Property
Public Property Get Database() As String
Database = This.Database
End Property
'**************************************************************************************************
' NAME : Provider (PROPERTY)
' TYPE : GET
'**************************************************************************************************
Public Property Get Provider(Optional eConnect As ConnectionString) As String
Select Case eConnect
Case Access
Provider = "Microsoft.ACE.OLEDB.12.0"
Case SQLServer
Provider = vbNullString
Case SQLLite
Provider = vbNullString
Case Base
Provider = vbNullString
End Select
End Property
'**************************************************************************************************
' NAME : Server (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let Server(sServer As String)
This.Server = sServer
End Property
Public Property Get Server() As String
Server = This.Server
End Property
'**************************************************************************************************
' NAME : Driver (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let Driver(sDriver As String)
This.Driver = sDriver
End Property
Public Property Get Driver() As String
Driver = This.Driver
End Property
'**************************************************************************************************
' NAME : User (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let User(sUser As String)
This.User = sUser
End Property
Public Property Get User() As String
User = This.User
End Property
'**************************************************************************************************
' NAME : Password (PROPERTY)
' TYPE : GET/LET
'**************************************************************************************************
Public Property Let Password(sPassword As String)
This.Password = sPassword
End Property
Public Property Get Password() As String
Password = This.Password
End Property
'**************************************************************************************************
' PUBLIC METHODE
'**************************************************************************************************
'**************************************************************************************************
' NAME : AddNew (FUNCTION)
' INPUT : sRequest (String), oConnect (ADODB.Connection), CursorType (Enum), LockType (Enum)
' OUTPUT : Request (Variant)
' SOURCE : https://ledzeppii.developpez.com/odbc-access/
'**************************************************************************************************
Public Function AddNew(ByVal sRequest As String, oConnect As ADODB.Connection, _
Optional CursorType As CursorTypeEnum = adOpenUnspecified, _
Optional LockType As LockTypeEnum = adLockUnspecified) As Variant
Const FUNCTION_NAME As String = "Add New Request"
On Error GoTo HANDLER_REQUEST
ReDim TabError(0 To 0, 0 To 0) As Variant
Dim Request As New ADODB.Recordset
If Right$(sRequest, 1) <> ";" Then sRequest = sRequest & ";"
If InStr(sRequest, "SELECT") <> 0 Then
With Request
.Open sRequest, oConnect, CursorType, LockType
If Not (.EOF And .BOF) Then AddNew = .GetRows
.Close
End With
Set Request = Nothing
Else
oConnect.Execute sRequest
TabError(0, 0) = FUNCTION_NAME & " - Good"
AddNew = TabError
Erase TabError
End If
Exit Function
HANDLER_REQUEST:
Set Request = Nothing
TabError(0, 0) = FUNCTION_NAME & " - Fail"
AddNew = TabError
Erase TabError
Err.Clear
End Function
'**************************************************************************************************
' NAME : CreateBase (FUNCTION)
' INPUT : sPathFile (String), sDataBase (String)
' OUTPUT : Request (String)
' SOURCE : https://sql.sh/cours/create-database
' STRUCTURE :
' CREATE DATABASE @Base
'**************************************************************************************************
Public Function CreateBase(sPathFile As String, sDatabase As String) As String
Const FUNCTION_NAME As String = "CreateDataBase"
On Error GoTo HANDLER_CREATE
Dim sRequest As String
sRequest = ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Base", sDatabase)
CreateBase = sRequest
Exit Function
HANDLER_CREATE:
CreateDataBase = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : CreateTable (FUNCTION)
' INPUT : sPathFile (string), sTable (string), Values (Dictionary)
' OUTPUT : Request (String)
' SOURCE : https://sql.sh/cours/create-table
' STRUCTURE :
' CREATE TABLE @Table
' (
' @Header @Type
' )
' EXAMPLE :
' Dim Fields As New Scripting.Dictionary
' sTable = "TestTable"
' Fields.Add "champ1", "INT"
' Fields.Add "champ2", "INT"
'
' This.PathFile = ThisWorkbook.Path & "\SQL\CREATE TABLE.txt"
' sRequest = CreateTable(This.PathFile, sTable, Fields)
'
' NOTE : The first field is primary key and not null
'**************************************************************************************************
Public Function CreateTable(sPathFile As String, sTable As String, Values As Dictionary) As String
Const FUNCTION_NAME As String = "CreateTable"
On Error GoTo HANDLER_CREATETABLE
Dim sRequest As String
Dim sBuffer As String
Dim bFirst As Boolean
Dim lBuffer As Long
bFirst = True
lBuffer = 1
sRequest = ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Table", sTable)
For Each This.Key In Values.Keys
If Not bFirst Then
sBuffer = sBuffer & This.Key & " " & Values.Item(This.Key)
Else
sBuffer = sBuffer & This.Key & " " & Values.Item(This.Key) & " PRIMARY KEY"
bFirst = False
End If
If lBuffer <> Values.Count Then
sBuffer = sBuffer & vbNewLine & vbTab
End If
lBuffer = lBuffer + 1
Next This.Key
sRequest = Replace(sRequest, "@Header @Type", sBuffer)
CreateTable = sRequest
Exit Function
HANDLER_CREATETABLE:
CreateTable = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLInsert (FUNCTION)
' INPUT : sPathFile (String), Fields (String Array), Values (Collection or Dictionary)
' OUTPUT : Request - String
' SOURCE : https://sql.sh/cours/insert-into
' STRUCTURE :
' INSERT INTO @Table (@Field)
' VALUES @Value;
'
' EXAMPLE :
' Dim sTable As String
' This.PathFile = ThisWorkbook.Path & "\SQL\INSERT.txt"
' sTable = "table"
'
' ReDim sFields(0 To 2) As String
' sFields(0) = "champ1"
' sFields(1) = "champ2"
'
' Dim Data As New Dictionary
' Data.Add "champ1", "value1"
' Data.Add "champ2", "value2"
'
' sRequest = SQLInsert(This.PathFile, sTable, sFields, Data)
' Result = AddNew(sRequest, Database)
'
'**************************************************************************************************
Public Function SQLInsert(sPathFile As String, sTable As String, sFields() As String, Values As Object) As String
Const FUNCTION_NAME As String = "SQLInsert"
On Error GoTo HANDLER_SQLINSERT
Dim sRequest As String
Dim sBuffer As String
Dim lBuffer As Long
sRequest = ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Table", sTable)
sRequest = Replace(sRequest, "@Field", Join(sFields, ", "))
For lBuffer = LBound(sFields, 1) To UBound(sFields, 1) Step 1
If lBuffer = LBound(sFields, 1) Then sBuffer = sBuffer & "("
If lBuffer <> UBound(sFields, 1) Then
sBuffer = sBuffer & FormatValue(Values(sFields(lBuffer))) & ", "
Else
sBuffer = sBuffer & FormatValue(Values(sFields(lBuffer))) & ")"
End If
Next lBuffer
sRequest = Replace(sRequest, "@Value", sBuffer)
SQLInsert = sRequest
Exit Function
HANDLER_SQLINSERT:
SQLInsert = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLSelect (FUNCTION)
' INPUT : sPathFile (String) - Values (Collection)
' OUTPUT : sRequest - String - SQL Request
' SOURCE : https://sql.sh/cours/select
' STRUCTURE :
' SELECT @Field
' FROM @Table
' EXAMPLE :
' Dim Values As New VBA.Collection
' Dim Field As New VBA.Collection
' Dim Table As New VBA.Collection
'
' This.PathFile = ThisWorkbook.Path & "\SQL\SELECT.txt"
'
' Field.Add "champ1"
' Field.Add "champ2"
' Table.Add "table1"
'
' Values.Add Field, "Field"
' Values.Add Table, "Table"
' sRequest = SQLSelect(This.PathFile, Values)
'**************************************************************************************************
Public Function SQLSelect(sPathFile As String, Values As Collection) As String
Const FUNCTION_NAME As String = "SQLSelect"
On Error GoTo HANDLER_SQLSELECT
Dim sRequest As String
Dim sBuffer As String
sRequest = ReadFile(sPathFile)
For Each This.Item In Values("Field")
If sBuffer = vbNullString Then
sBuffer = CStr(This.Item)
Else
sBuffer = sBuffer & ", " & CStr(This.Item)
End If
Next This.Item
sRequest = Replace(sRequest, "@Field", sBuffer)
sBuffer = vbNullString
For Each This.Item In Values("Table")
If sBuffer = vbNullString Then
sBuffer = CStr(This.Item)
Else
sBuffer = sBuffer & ", " & CStr(This.Item)
End If
Next This.Item
sRequest = Replace(sRequest, "@Table", sBuffer)
SQLSelect = sRequest
Exit Function
HANDLER_SQLSELECT:
SQLSelect = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLUpdate (FUNCTION)
' INPUT : sPathFile (String), Values (Collection)
' OUTPUT : Request (String)
' SOURCE : https://sql.sh/cours/update
' STRUCTURE :
' UPDATE @Table
' SET @Field @Operator @Value
' RESTRICTION : SQLWhere and Values need keys (Table, Field, Value)
'**************************************************************************************************
Public Function SQLUpdate(sPathFile As String, Values As Collection) As String
Const FUNCTION_NAME As String = "SQLUpdate"
On Error GoTo HANDLER_SQLUPDATE
Dim sRequest As String
sRequest = ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Table", Values("Table"))
sRequest = Replace(sRequest, "@Field", Values("Field"))
sRequest = Replace(sRequest, "@Operator", Values("Operator"))
sRequest = Replace(sRequest, "@Value", FormatValue(Values("Value")))
sRequest = SQLUpdate
HANDLER_SQLUPDATE:
SQLUpdate = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLDelete (FUNCTION)
' INPUT : sPathFile (String), Values (Collection)
' OUTPUT : Request (String)
' SOURCE : https://sql.sh/cours/delete
' STRUCTURE :
' DELETE FROM `@Table`
' WHERE `@Field` @Operator @Value;
' RESTRICTION :
'**************************************************************************************************
Public Function SQLDelete(sPathFile As String, Values As Collection) As String
Const FUNCTION_NAME As String = "SQLDelete"
On Error GoTo HANDLER_SQLDELETE
Dim sRequest As String
sRequest = Replace(sRequest, "@Table", Values("Table"))
sRequest = Replace(sRequest, "@Field", Values("Field"))
sRequest = Replace(sRequest, "@Operator", Values("Operator"))
sRequest = Replace(sRequest, "@Value", FormatValue(Values("Value")))
sRequest = SQLDelete
HANDLER_SQLDELETE:
SQLDelete = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLWhere (FUNCTION)
' INPUT : sPathFile (String), Values (Collection)
' OUTPUT : Request - String - SQL Request
' SOURCE : https://sql.sh/cours/where
' STRUCTURE :
' WHERE @Field @Operator @Value
'
' EXAMPLE :
' Dim Where As New VBA.Collection
' Where.Add "champ1", "Field"
' Where.Add "=", "Operator"
' Where.Add "value1", "Value"
'
' sRequest = SQLWhere(This.PathFile, Where, sRequest)
'
' RESTRICTION : Values needed keys (Field, Operator, Value)
'**************************************************************************************************
Public Function SQLWhere(ByVal sPathFile As String, ByVal Values As Collection, _
Optional sRequest As String = vbNullString) As String
Const FUNCTION_NAME As String = "SQLWhere"
On Error GoTo HANDLER_SQLWHERE
Dim sBuffer As String
sBuffer = FormatValue(Values("Value"))
If InStr(sRequest, "WHERE") <> 0 Then
sRequest = sRequest & vbNewLine & Replace(ReadFile(sPathFile), "WHERE", "AND")
Else
sRequest = sRequest & vbNewLine & ReadFile(sPathFile)
End If
sRequest = Replace(sRequest, "@Field", Values("Field"))
sRequest = Replace(sRequest, "@Operator", Values("Operator"))
sRequest = Replace(sRequest, "@Value", sBuffer)
SQLWhere = sRequest
Exit Function
HANDLER_SQLWHERE:
SQLWhere = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLJoin (FUNCTION)
' INPUT :
' OUTPUT :
' SOURCE : https://sqlpro.developpez.com/cours/sqlaz/jointures/
' STRUCTURE :
' JOIN @Table ON (@FromKey = @ToKey)
'**************************************************************************************************
Public Function SQLJoin(ByVal sPathFile As String, Values As Collection, _
Optional sRequest As String = vbNullString) As String
Const FUNCTION_NAME As String = "SQLJoin"
On Error GoTo HANDLER_SQLJOIN
sRequest = sRequest & ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Table", Values("Table"))
sRequest = Replace(sRequest, "@FromKey", Values("FromKey"))
sRequest = Replace(sRequest, "@ToKey", Values("ToKey"))
SQLJoin = sRequest
Exit Function
HANDLER_SQLJOIN:
SQLJoin = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLGroupBy (FUNCTION)
' INPUT : sPathFile (String), Values (Collection), sRequest (String)
' OUTPUT : sRequest (String)
' SOURCE : https://sql.sh/cours/group-by
' STRUCTURE :
' GROUP BY colonne1
'**************************************************************************************************
Public Function SQLGroupBy(ByVal sPathFile As String, Values As Collection, _
Optional sRequest As String = vbNullString) As String
Const FUNCTION_NAME As String = "SQLSQLGroupBy"
On Error GoTo HANDLER_SQLGROUPBY
sRequest = sRequest & ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Field", Values("Field"))
SQLGroupBy = sRequest
HANDLER_SQLGROUPBY:
SQLGroupBy = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : SQLOrderBy (FUNCTION)
' INPUT : sPathFile (String), Values (Collection), sRequest (String)
' OUTPUT : sRequest (String)
' SOURCE : https://sql.sh/cours/order-by
' STRUCTURE :
' ORDER BY colonne1 DESC
'**************************************************************************************************
Public Function SQLOrderBy(ByVal sPathFile As String, Values As Collection, _
Optional sRequest As String = vbNullString) As String
Const FUNCTION_NAME As String = "SQLOrderby"
On Error GoTo HANDLER_SQLORDERBY
sRequest = sRequest & ReadFile(sPathFile)
sRequest = Replace(sRequest, "@Field", Values("Field"))
sRequest = Replace(sRequest, "@Order", Values("Order"))
SQLOrderBy = sRequest
Exit Function
HANDLER_SQLORDERBY:
SQLOrderBy = FUNCTION_NAME & " - Fail"
Err.Clear
End Function
'**************************************************************************************************
' NAME : ConnectToAccess (FUNCTION)
' INPUT : sProvider (String), sDatabase (String), sUser (String), sPassword (String)
' OUTPUT : ADODB.Connection
' SOURCE : http://learnexcelmacro.com/wp/2011/12/how-to-connect-to-access-database-excel-macro/
' NOTE : Using for Access
' EXAMPLE :
' Dim Database As ADODB.Connection
' This.Database = ThisWorkbook.Path & "\" & "Base.accdb"
' Set Database = ConnectToAccess(Provider(Access), This.Database)
'
' If Not Database Is Nothing Then
' Debug.Print "Test Connect to base Good"
' Else
' Debug.Print "Test Connect to base Fail"
' End If
'**************************************************************************************************
Public Function ConnectToAccess(sProvider As String, sDatabase As String, _
Optional sUser As String = vbNullString, _
Optional sPassword As String = vbNullString) As ADODB.Connection
Const FUNCTION_NAME As String = "ConnectToAccess"
On Error GoTo HANDLER_CONNECTACCESS
Dim sConnect As String
Dim Connect As New ADODB.Connection
If Connect.State = adStateOpen Then Connect.Close
sConnect = "Provider=@Provider;Data Source=@Database;Jet OLEDB:Database Password=@Password;"
sConnect = Replace(sConnect, "@Provider", sProvider)
sConnect = Replace(sConnect, "@Database", sDatabase)
sConnect = Replace(sConnect, "@Password", sPassword)
Connect.Open sConnect
While (Connect.State = adStateConnecting)
DoEvents
Wend
If Connect.State = adStateOpen Then
Set ConnectToAccess = Connect
Else
GoTo HANDLER_CONNECTACCESS
End If
Exit Function
HANDLER_CONNECTACCESS:
Set ConnectToAccess = Nothing
Err.Clear
End Function
'**************************************************************************************************
' NAME : ConnectToServer (FUNCTION)
' INPUT : sDriver (string), sServer (string), sDataBase (string), sUser (string),sPassword (string)
' OUTPUT : ADODB.Connection
' NOTE : Using for MySQL or SQLServer
'**************************************************************************************************
Public Function ConnectToServer(sDriver As String, sServer As String, sDatabase As String, _
Optional sUser As String = vbNullString, _
Optional sPassword As String = vbNullString) As ADODB.Connection
Const FUNCTION_NAME As String = "ConnectToServer"
On Error GoTo HANDLER_CONNECTSERVER
Dim sConnect As String
Dim Connect As New ADODB.Connection
sConnect = "DRIVER=" & sDriver & Chr$(59)
sConnect = sConnect & "SERVER=" & sServer & Chr$(59)
sConnect = sConnect & "DATABASE=" & sDatabase & Chr$(59)
sConnect = sConnect & "USER=" & sUser & Chr$(59)
sConnect = sConnect & "PASSWORD=" & sPassword
sConnect = Trim$(sConnect)
Connect.Open sConnect
While (Connect.State = adStateConnecting)
DoEvents
Wend
If Connect.State = adStateOpen Then
Set ConnectToAccess = Connect
Else
GoTo HANDLER_CONNECTACCESS
End If
Exit Function
HANDLER_CONNECTSERVER:
Set ConnectToServer = Nothing
Err.Clear
End Function
'**************************************************************************************************
' PRIVATE METHODE
'**************************************************************************************************
'**************************************************************************************************
' NAME : ReadFile (FUNCTION)
' INPUT : sPathFile (string)
' OUTPUT : ReadFile (string array)
' SOURCE : https://warin.developpez.com/access/fichiers/#LII-B-1
'**************************************************************************************************
Private Function ReadFile(ByVal sPathFile As String) As String
Const FUNCTION_NAME As String = "ReadFile"
On Error GoTo HANDLER_READFILE
Dim lMemory As Long
Dim lBuffer As Long
Dim sTabBuffer() As String
Dim sBuffer As String
Dim sTemp As String
lMemory = FreeFile
lBuffer = 1
Open sPathFile For Input As #lMemory
While Not EOF(lMemory)
If Not lBuffer = 1 Then
sBuffer = sBuffer & vbNewLine
Line Input #lMemory, sTemp
Else
Line Input #lMemory, sTemp
End If
sBuffer = sBuffer & sTemp
lBuffer = lBuffer + 1
Wend
Close (lMemory)
ReadFile = sBuffer
Exit Function
HANDLER_READFILE:
ReadFile = vbNullString
Err.Clear
End Function
'**************************************************************************************************
' NAME : FormatValue (FUNCTION)
' INPUT : Value (Variant)
' OUTPUT : String
'**************************************************************************************************
Private Function FormatValue(Value As Variant) As String
Select Case VarType(Value)
Case vbString
If InStr(Value, "'") = 0 Then
FormatValue = "'" & CStr(Value) & "'"
Else
FormatValue = "''" & CStr(Value) & "''"
End If
Case vbLong, vbDouble, vbInteger
FormatValue = Replace(CStr(Value), ",", ".")
Case vbDate
FormatValue = Format$(Value, "\#mm\/dd\/yyyy hh\:nn\:ss\#")
Case Else
FormatValue = vbNullString
End Select
End Function |
Module VBA - SQL
Répondre avec citation
Partager