-
Notifications
You must be signed in to change notification settings - Fork 1
Expand file tree
/
Copy pathQA.bas
More file actions
2602 lines (2200 loc) · 105 KB
/
QA.bas
File metadata and controls
2602 lines (2200 loc) · 105 KB
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
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Attribute VB_Name = "QAModule"
'Deze module bevat de hoofdprocedures van dit programma.
Option Explicit
'De door dit programma gebruikte Microsoft Windows API-constanten, -functies en -structuren.
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const SW_SHOWNORMAL As Long = 1
Private Const ERROR_SUCCESS As Long = 0
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&
Private Const MAX_STRING As Long = 65535
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_FILEMUSTEXIST As Long = &H1000&
Private Const OFN_HIDEREADONLY As Long = &H4&
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8&
Private Const OFN_PATHMUSTEXIST As Long = &H800&
Public Declare Function ShellExecuteA Lib "Shell32.dll" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function FormatMessageA Lib "Kernel32.dll" (ByVal dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function GetOpenFileNameA Lib "Comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileNameA Lib "Comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SafeArrayGetDim Lib "Oleaut32.dll" (ByRef saArray() As Any) As Long
Private Declare Function SetCurrentDirectoryA Lib "Kernel32.dll" (ByVal lpPathName As String) As Long
Private Declare Function WaitMessage Lib "User32.dll" () As Long
'De door dit programma gebruikte constanten, definities, en opsommingen.
'Bevat een opsomming van de parameter definitie elementen.
Private Enum ParameterDefinitieOpsomming
NaamElement
MaskerElement
StandaardWaardeElement
CommentaarElement
End Enum
'Bevat de definities voor de instellingen van dit programma.
Public Type InstellingenDefinitie
BatchBereik As String 'Definieert de volgnummers van de eerste en de laatste query in een uit te voeren batch.
BatchInteractief As Boolean 'Definieert of de gebruiker eerst parameters moet invoeren voordat een batch uitgevoerd kan worden.
BatchQueryPad As String 'Definieert het pad en/of de bestandsnaam zonder volgnummers van de query's in een uit te voeren batch.
Bestand As String 'Definieert het pad en/of de bestandsnaam van het programmainstellingenbestand.
EMailTekst As String 'Definieert de tekst van de e-mail met de geëxporteerde resultaten.
ExportAfzender As String 'Definieert de naam van de afzender van de e-mail met de geëxporteerde resultaten.
ExportAutoOpenen As Boolean 'Definieert of een export automatisch na het exporteren geopend wordt.
ExportAutoOverschrijven As Boolean 'Definieert of een bestand automatisch overschreven wordt bij het exporteren van de queryresultaataten.
ExportAutoVerzenden As Boolean 'Definieert of de e-mail met de geëxporteerde resultaten automatisch verzonden wordt.
ExportCCOntvanger As String 'Definieert het e-mail adres van de ontvanger van het kopie van de e-mail met de geëxporteerde resultaten.
ExportKolomAanvullen As Boolean 'Definieert of de data in een kolom moet worden aangevuld met spaties.
ExportOnderwerp As String 'Definieert het onderwerp van de e-mail met de geëxporteerde resultaten.
ExportOntvanger As String 'Definieert het e-mail adres van de ontvanger van de e-mail met de geëxporteerde resultaten.
ExportStandaardPad As String 'Definieert het standaardpad voor het exporteren van queryresultaataten.
QueryAutoSluiten As Boolean 'Definieert of dit programma na het uitvoeren van een query en een eventuele export automatisch afgesloten wordt.
QueryAutoUitvoeren As Boolean 'Definieert of een query automatisch uitgevoerd wordt na het laden.
QueryRecordSets As Boolean 'Definieert of er meer dan een recordset kan worden teruggestuurd door de database als het resultaat van een query.
QueryTimeout As Long 'Definieert het aantal seconden dat het programma wacht op het queryresultaat nadat opdracht is gegeven de query uit te voeren.
VoorbeeldKolomBreedte As Long 'Definieert de maximale kolombreedte die gebruikt wordt om het queryresultaat te tonen in het voorbeeld venster.
VoorbeeldRegels As Long 'Definieert het maximum aantal regels dat van het queryresultaat wordt getoond in het voorbeeld venster.
VerbindingsInformatie As String 'Defines de voor de verbinding met een database noodzakelijke gegevens.
End Type
'Bevat de definities voor de opdrachtregelparameters die eventueel zijn opgegeven bij het starten van dit programma.
Public Type OpdrachtRegelParametersDefinitie
InstellingenPad As String 'Definieert het opgegeven instellingenpad.
QueryPad As String 'Definieert het opgegeven querypad.
SessiesPad As String 'Definieert het opgegeven sessielijstpad.
Verwerkt As Boolean 'Definieert of de opdrachtregelparameters zonder fouten zijn verwerkt.
End Type
'Bevat de definities voor een query.
Public Type QueryDefinitie
Code As String 'Defines de code van een query.
Pad As String 'Defines het pad van een querybestand.
Geopend As Boolean 'Definieert of het querybestand kon worden geopend.
End Type
'Bevat de definities voor de parameter gegevens van de geselecteerde query.
Public Type QueryParameterDefinitie
Commentaar As String 'Definieert het commentaar bij de parameter.
Invoer As String 'Definieert de invoer van de gebruiker.
Lengte As Long 'Definieert de lengte van de parameterdefinitie.
LengteIsVariabel As Boolean 'Definieert of de lengte van de invoer variabel is.
Masker As String 'Definieert het invoer masker van de parameter.
ParameterNaam As String 'Definieert de naam van de parameter.
Positie As Long 'Definieert de positie relatief ten op zichte van de vorige definitie.
StandaardWaarde As String 'Definieert de standaardwaarde van de parameter.
VeldIsZichtbaar As Boolean 'Definieert of het invoer veld zichtbaar is.
End Type
'Bevat de definities voor het resultaat van een query.
Public Type QueryResultaatDefinitie
KolomBreedte() As Long 'Definieert per kolom de maximale breedte in bytes van de gegevens.
RechtsUitlijnen() As Boolean 'Definieert per kolom of de gegevens rechtsuitgelijnd worden bij weergave.
Tabel() As String 'Definieert de door een query opgevraagde gegevens uit een database.
End Type
Public Const GEBRUIKER_VARIABEL As String = "$$GEBRUIKER$$" 'Indien aanwezig in de verbindingsinformatie geeft dit variabel de positie van de gebruikersnaam aan.
Public Const GEEN_PARAMETER As Long = -1 'Staat voor "geen parameter".
Public Const WACHTWOORD_VARIABEL As String = "$$WACHTWOORD$$" 'Indien aanwezig in de verbindingsinformatie geeft dit variabel de positie van het wachtwoord aan.
Private Const ASCII_A As Long = 65 'De ASCII-waarde voor het teken "A".
Private Const ASCII_Z As Long = 90 'De ASCII-waarde voor het teken "Z".
Private Const COMMENTAAR_TEKEN As String = "#" 'Geeft aan dat een regel in een instellingenbestand commentaar is.
Private Const DEFINITIE_TEKENS As String = "$$" 'Geeft het begin en het einde van een parameterdefinitie binnen een query aan.
Private Const ELEMENT_TEKEN As String = ":" 'Scheidt de parameter definitie elementen van elkaar.
Private Const EXCEL_MAXIMUM_AANTAL_KOLOMMEN As Long = 255 'Het maximale aantal door Microsoft Excel ondersteunde kolommen.
Private Const GEEN_LETTER As Long = 64 'Staat voor "geen letter". (De ASCII-waarde die voor het "A" teken komt.)
Private Const GEEN_MAXIMUM As Long = -1 'Staat voor "geen maximale kolom breedte of maximum aantal regels in voorbeeld".
Private Const GEEN_RESULTAAT As Long = -1 'Staat voor "geen queryresultaat".
Private Const MASKER_CIJFER As String = "#" 'Geeft in een masker aan dat er een cijfer als invoer wordt verwacht.
Private Const MASKER_HOOFDLETTER As String = "_" 'Geeft in een masker aan dat er een hoofdletter als invoer wordt verwacht.
Private Const ONBEKEND_AANTAL As Long = -1 'Staat voor "onbekend aantal voor de opgegeven dimensie in de opgegeven array".
Private Const PARAMETER_TEKEN As String = "?" 'Scheidt de opdrachtregelparameters van elkaar.
Private Const SECTIE_NAAM_BEGIN As String = "[" 'Geeft het begin van een sectie naam in een instellingenbestand aan.
Private Const SECTIE_NAAM_EINDE As String = "]" 'Geeft het einde van een sectie naam in een instellingenbestand aan.
Private Const SQL_COMMENTAAR_BLOK_BEGIN As String = "/*" 'Staat voor het begin van een SQL-commentaarblok.
Private Const SQL_COMMENTAAR_BLOK_EINDE As String = "*/" 'Staat voor het einde van een SQL-commentaarblok.
Private Const SQL_COMMENTAAR_REGEL_BEGIN As String = "--" 'Staat voor het begin van een SQL-commentaarregel.
Private Const SQL_COMMENTAAR_REGEL_EINDE As String = vbNullString 'Staat voor het einde van een SQL-commentaarregel.
Private Const SYMBOOL_TEKEN As String = "*" 'Geeft het begin en het einde van een symbool in een tekst aan.
Private Const TEKENREEKS_TEKENS As String = "'""" 'Staat voor de tekens die het begin en einde van een tekenreeks aanduiden.
Private Const VARIABELE_LENGTE_TEKEN As String = "*" 'Indien aanwezig aan het begin van een masker geeft dit teken aan dat de invoer lengte variabel is.
Private Const VERBINDING_PARAMETER_TEKEN As String = ";" 'Scheidt de verbindingsinformatieparameters van elkaar.
Private Const WAARDE_TEKEN As String = "=" 'Scheidt de naam en waarde van een instellingenparameter van elkaar.
'Deze procedure stuurt het aantal items min een voor de opgegeven dimensie in de opgegeven array terug.
Private Function AantalItems(ArrayV As Variant, Optional Dimensie As Long = 1) As Long
On Error GoTo Fout
Dim Aantal As Long
Aantal = UBound(ArrayV, Dimensie) - LBound(ArrayV, Dimensie)
EindeProcedure:
AantalItems = Aantal
Exit Function
Fout:
Aantal = ONBEKEND_AANTAL
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure geeft aan of de batchmodus actief is.
Public Function BatchModusActief() As Boolean
On Error GoTo Fout
EindeProcedure:
With Instellingen()
BatchModusActief = Not (.BatchBereik = vbNullString Or .BatchQueryPad = vbNullString)
End With
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure beheert bestandssysteem gerelateerde functies.
Public Function BestandsSysteem() As FileSystemObject
On Error GoTo Fout
Static HuidigBestandSysteem As New FileSystemObject
EindeProcedure:
Set BestandsSysteem = HuidigBestandSysteem
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure bewaart de instellingen van dit programma.
Private Sub BewaarInstellingen(InstellingenPad As String, TeBewarenInstellingen As InstellingenDefinitie, Bericht As String)
On Error GoTo Fout
Dim BestandsHandle As Long
BestandsHandle = FreeFile()
Open InstellingenPad For Output Lock Read Write As BestandsHandle
With TeBewarenInstellingen
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "BATCH" & SECTIE_NAAM_EINDE
Print #BestandsHandle, "Bereik" & WAARDE_TEKEN & .BatchBereik
Print #BestandsHandle, "Interactief" & WAARDE_TEKEN & CStr(.BatchInteractief)
Print #BestandsHandle, "QueryPad" & WAARDE_TEKEN & .BatchQueryPad
Print #BestandsHandle,
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "EMAILTEKST" & SECTIE_NAAM_EINDE
Print #BestandsHandle, .EMailTekst
Print #BestandsHandle,
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "EXPORT" & SECTIE_NAAM_EINDE
Print #BestandsHandle, "Afzender" & WAARDE_TEKEN & .ExportAfzender
Print #BestandsHandle, "AutoOpenen" & WAARDE_TEKEN & CStr(.ExportAutoOpenen)
Print #BestandsHandle, "AutoOverschrijven" & WAARDE_TEKEN & CStr(.ExportAutoOverschrijven)
Print #BestandsHandle, "AutoVerzenden" & WAARDE_TEKEN & CStr(.ExportAutoVerzenden)
Print #BestandsHandle, "CCOntvanger" & WAARDE_TEKEN & .ExportCCOntvanger
Print #BestandsHandle, "KolomAanvullen" & WAARDE_TEKEN & CStr(.ExportKolomAanvullen)
Print #BestandsHandle, "Onderwerp" & WAARDE_TEKEN & .ExportOnderwerp
Print #BestandsHandle, "Ontvanger" & WAARDE_TEKEN & .ExportOntvanger
Print #BestandsHandle, "StandaardPad" & WAARDE_TEKEN & .ExportStandaardPad
Print #BestandsHandle,
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "QUERY" & SECTIE_NAAM_EINDE
Print #BestandsHandle, "AutoSluiten" & WAARDE_TEKEN & CStr(.QueryAutoSluiten)
Print #BestandsHandle, "AutoUitvoeren" & WAARDE_TEKEN & CStr(.QueryAutoUitvoeren)
Print #BestandsHandle, "Recordsets" & WAARDE_TEKEN & CStr(.QueryRecordSets)
Print #BestandsHandle, "Timeout" & WAARDE_TEKEN & CStr(.QueryTimeout)
Print #BestandsHandle,
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "VERBINDING" & SECTIE_NAAM_EINDE
Print #BestandsHandle, .VerbindingsInformatie
Print #BestandsHandle,
Print #BestandsHandle, SECTIE_NAAM_BEGIN & "VOORBEELD" & SECTIE_NAAM_EINDE
Print #BestandsHandle, "KolomBreedte" & WAARDE_TEKEN & CStr(.VoorbeeldKolomBreedte)
Print #BestandsHandle, "Regels" & WAARDE_TEKEN & CStr(.VoorbeeldRegels)
End With
Close BestandsHandle
MsgBox Bericht & vbCr & InstellingenPad, vbInformation
EindeProcedure:
Close BestandsHandle
Exit Sub
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False, TypePad:="Instellingenbestand: ", Pad:=InstellingenPad) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Sub
'Deze procedure controleert of er een fout is opgetreden tijdens de recenste API-functie aanroep.
Public Function ControleerOpAPIFout(TerugGestuurd As Long, Optional ExtraInformatie As String = vbNullString) As Long
Dim Bericht As String
Dim FoutCode As Long
Dim Lengte As Long
Dim Omschrijving As String
FoutCode = Err.LastDllError
Err.Clear
On Error GoTo Fout
If Not FoutCode = ERROR_SUCCESS Then
Omschrijving = String$(MAX_STRING, vbNullChar)
Lengte = FormatMessageA(FORMAT_MESSAGE_ARGUMENT_ARRAY Or FORMAT_MESSAGE_FROM_SYSTEM, CLng(0), FoutCode, CLng(0), Omschrijving, Len(Omschrijving), StrPtr(StrConv(ExtraInformatie, vbFromUnicode)))
If Lengte = 0 Then
Omschrijving = "Geen omschrijving."
Else
Omschrijving = Left$(Omschrijving, Lengte - 1)
End If
Bericht = "API Foutcode: " & CStr(FoutCode) & vbCr
Bericht = Bericht & Omschrijving
If Not Right$(Bericht, 1) = vbCr Then Bericht = Bericht & vbCr
Bericht = Bericht & "Terug gestuurde waarde: " & CStr(TerugGestuurd)
MsgBox Bericht, vbExclamation
End If
EindeProcedure:
ControleerOpAPIFout = TerugGestuurd
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure stuurt de Microsoft Excel kolom id voor het opgegeven kolom nummer terug.
Private Function ExcelKolomId(ByVal Kolom As Long) As String
On Error GoTo Fout
Dim KolomId As String
Dim Letter1 As Long
Dim Letter2 As Long
KolomId = vbNullString
If Kolom > EXCEL_MAXIMUM_AANTAL_KOLOMMEN Then
ExcelKolomId = vbNullString
Exit Function
End If
For Letter1 = GEEN_LETTER To ASCII_Z
For Letter2 = ASCII_A To ASCII_Z
If Kolom = 0 Then
If Letter1 = GEEN_LETTER Then
KolomId = Chr$(Letter2)
Else
KolomId = Chr$(Letter1) & Chr$(Letter2)
End If
ExcelKolomId = KolomId
Exit Function
End If
Kolom = Kolom - 1
Next Letter2
Next Letter1
EindeProcedure:
ExcelKolomId = KolomId
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure exporteert het queryresultaat naar een tekstbestand.
Private Function ExporteerAlsTekst(ExportPad As String) As Boolean
On Error GoTo Fout
Dim BestandsHandle As Long
Dim EersteResultaat As Long
Dim ExportAfgebroken As Boolean
Dim Kolom As Long
Dim LaatsteResultaat As Long
Dim ResultaatIndex As Long
Dim Rij As Long
ExportAfgebroken = False
QueryResultaten , , , EersteResultaat, LaatsteResultaat
BestandsHandle = FreeFile()
Open ExportPad For Output Lock Read Write As BestandsHandle
For ResultaatIndex = EersteResultaat To LaatsteResultaat
With QueryResultaten(, , ResultaatIndex)
If Not ControleerOpAPIFout(SafeArrayGetDim(.Tabel())) = 0 Then
If Not LaatsteResultaat = EersteResultaat Then Print #BestandsHandle, "[Resultaat: #" & CStr((ResultaatIndex - EersteResultaat) + 1) & "]"
For Rij = LBound(.Tabel(), 1) To UBound(.Tabel(), 1)
For Kolom = LBound(.Tabel(), 2) To UBound(.Tabel(), 2)
If Instellingen().ExportKolomAanvullen Then
Print #BestandsHandle, VulAan(.Tabel(Rij, Kolom), .KolomBreedte(Kolom), .RechtsUitlijnen(Kolom)) & " ";
Else
Print #BestandsHandle, .Tabel(Rij, Kolom); vbTab;
End If
Next Kolom
Print #BestandsHandle,
Next Rij
End If
End With
Next ResultaatIndex
EindeProcedure:
Close BestandsHandle
ExporteerAlsTekst = ExportAfgebroken
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False, TypePad:="Export pad: ", Pad:=ExportPad) = vbIgnore Then
ExportAfgebroken = True
Resume EindeProcedure
End If
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure exporteert het queryresultaat naar een Microsoft Excel werkmap.
Private Function ExporteerNaarExcel(ExportPad As String, ExcelFormaat As Long) As Boolean
On Error GoTo Fout
Dim Bericht As String
Dim EersteResultaat As Long
Dim ExportAfgebroken As Boolean
Dim Kolom As Long
Dim KolomId As String
Dim LaatsteResultaat As Long
Dim MSExcel As New Excel.Application
Dim ResultaatIndex As Long
Dim WerkBlad As Excel.Worksheet
Dim WerkMap As Excel.Workbook
ExportAfgebroken = False
QueryResultaten , , , EersteResultaat, LaatsteResultaat
MSExcel.DisplayAlerts = False
MSExcel.Interactive = False
MSExcel.ScreenUpdating = False
MSExcel.Workbooks.Add
Set WerkMap = MSExcel.Workbooks.Item(1)
WerkMap.Activate
Do Until WerkMap.Worksheets.Count <= 1
WerkMap.Worksheets.Item(WerkMap.Worksheets.Count).Delete
Loop
Do Until WerkMap.Worksheets.Count >= Abs(LaatsteResultaat - EersteResultaat) + 1
WerkMap.Worksheets.Add
Loop
For ResultaatIndex = EersteResultaat To LaatsteResultaat
With QueryResultaten(, , ResultaatIndex)
If Not ControleerOpAPIFout(SafeArrayGetDim(.Tabel())) = 0 Then
If AantalItems(.Tabel, Dimensie:=2) > EXCEL_MAXIMUM_AANTAL_KOLOMMEN Then
Bericht = "Het queryresultaat bevat te veel kolommen om deze naar Microsoft Excel te exporteren." & vbCr
Bericht = Bericht & "Het maximaal toegestane aantal kolommen is: " & CStr(EXCEL_MAXIMUM_AANTAL_KOLOMMEN)
MsgBox Bericht, vbExclamation
Else
Set WerkBlad = WerkMap.Worksheets.Item((ResultaatIndex - EersteResultaat) + 1)
WerkBlad.Activate
If Not LaatsteResultaat = EersteResultaat Then WerkBlad.Name = "Resultaat " & CStr((ResultaatIndex - EersteResultaat) + 1)
WerkBlad.Range("A1:" & ExcelKolomId(AantalItems(.Tabel(), Dimensie:=2)) & CStr(AantalItems(.Tabel(), Dimensie:=1) + 1)).Value = .Tabel()
For Kolom = LBound(.Tabel(), 2) To UBound(.Tabel(), 2)
KolomId = ExcelKolomId(Kolom)
WerkBlad.Range(KolomId & "1:" & KolomId & "1").Font.Bold = True
If .RechtsUitlijnen(Kolom) Then WerkBlad.Range(KolomId & "1:" & KolomId & CStr(AantalItems(.Tabel(), Dimensie:=1) + 1)).HorizontalAlignment = xlRight
Next Kolom
WerkBlad.Range("A:" & ExcelKolomId(AantalItems(.Tabel(), Dimensie:=2))).Columns.AutoFit
End If
End If
End With
If ResultaatIndex = LaatsteResultaat Then
WerkMap.Worksheets.Item(1).Activate
WerkMap.SaveAs ExportPad, ExcelFormaat
WerkMap.Close
End If
Next ResultaatIndex
EindeProcedure:
If Not MSExcel Is Nothing Then
MSExcel.Quit
MSExcel.DisplayAlerts = True
MSExcel.Interactive = True
MSExcel.ScreenUpdating = True
End If
Set MSExcel = Nothing
Set WerkBlad = Nothing
Set WerkMap = Nothing
ExporteerNaarExcel = ExportAfgebroken
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False, TypePad:="Export pad: ", Pad:=ExportPad) = vbIgnore Then
ExportAfgebroken = True
Resume EindeProcedure
End If
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure exporteert het queryresultaat.
Public Function ExporteerResultaat(ExportPad As String) As Boolean
On Error GoTo Fout
Dim BestandsType As String
Dim ExportAfgebroken As Boolean
ExportAfgebroken = False
BestandsType = LCase$(Trim$("." & BestandsSysteem().GetExtensionName(ExportPad)))
If BestandsSysteem().FileExists(ExportPad) Then
If Not Instellingen().ExportAutoOverschrijven Then
If MsgBox("Het bestand """ & ExportPad & """ bestaat al. Overschrijven?", vbQuestion Or vbYesNo Or vbDefaultButton2) = vbNo Then ExportAfgebroken = True
End If
If Not ExportAfgebroken Then
If BestandsType = ".xls" Or BestandsType = ".xlsx" Then SluitExcelWerkmap ExportPad
Kill ExportPad
End If
End If
If Not ExportAfgebroken Then
Select Case BestandsType
Case ".xls"
ExportAfgebroken = ExporteerNaarExcel(ExportPad, xlWorkbookNormal)
Case ".xlsx"
ExportAfgebroken = ExporteerNaarExcel(ExportPad, xlWorkbookDefault)
Case Else
ExportAfgebroken = ExporteerAlsTekst(ExportPad)
End Select
End If
EindeProcedure:
ExporteerResultaat = Not ExportAfgebroken
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then
ExportAfgebroken = True
Resume EindeProcedure
End If
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure zet de opgegeven fouten lijst om naar tekst.
Public Function FoutenLijstTekst(Lijst As Adodb.Errors) As String
On Error GoTo Fout
Dim Fout As Adodb.Error
Dim Tekst As String
Tekst = "Er "
If Lijst.Count = 1 Then Tekst = Tekst & "is 1 fout " Else Tekst = Tekst & "zijn " & CStr(Lijst.Count) & " fouten"
Tekst = Tekst & " opgetreden tijdens het uitvoeren van de query:" & vbCrLf
Tekst = Tekst & VulAan("Native", 11)
Tekst = Tekst & VulAan("Code", 11)
Tekst = Tekst & VulAan("Bron", 36)
Tekst = Tekst & VulAan("SQL status", 11)
Tekst = Tekst & "Omschrijving" & vbCrLf
For Each Fout In Lijst
With Fout
Tekst = Tekst & VulAan(CStr(.NativeError), 10, LinksAanvullen:=True) & " "
Tekst = Tekst & VulAan(CStr(.Number), 10, LinksAanvullen:=True) & " "
Tekst = Tekst & VulAan(.Source, 35) & " "
Tekst = Tekst & VulAan(.SqlState, 10, LinksAanvullen:=True) & " "
Tekst = Tekst & .Description & vbCrLf
End With
Next Fout
EindeProcedure:
FoutenLijstTekst = Tekst
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure handelt eventuele fouten af.
Public Function HandelFoutAf(Optional VraagVorigeKeuzeOp As Boolean = True, Optional TypePad As String = vbNullString, Optional Pad As String = vbNullString, Optional ExtraInformatie As String = vbNullString) As Long
Dim Bericht As String
Dim Bron As String
Dim FoutCode As Long
Dim FoutOmschrijving As String
Static Keuze As Long
Bron = Err.Source
FoutCode = Err.Number
FoutOmschrijving = Err.Description
Err.Clear
On Error Resume Next
If Not VraagVorigeKeuzeOp Then
Bericht = MaakFoutOmschrijvingOp(FoutOmschrijving) & vbCr
Bericht = Bericht & "Foutcode: " & CStr(FoutCode)
If Not Bron = vbNullString Then Bericht = Bericht & vbCr & "Bron: " & Bron
If Not (TypePad = vbNullString Or Pad = vbNullString) Then Bericht = Bericht & vbCr & TypePad & BestandsSysteem().GetAbsolutePathName(Pad)
If Not ExtraInformatie = vbNullString Then Bericht = Bericht & vbCr & ExtraInformatie
Keuze = MsgBox(Bericht, vbExclamation Or vbAbortRetryIgnore Or vbDefaultButton2)
End If
HandelFoutAf = Keuze
If Keuze = vbAbort Then End
End Function
'Deze procedure stuurt de instellingen voor dit programma terug.
Public Function Instellingen(Optional InstellingenPad As String = vbNullString) As InstellingenDefinitie
On Error GoTo Fout
Dim Bericht As String
Static ProgrammaInstellingen As InstellingenDefinitie
If Not InstellingenPad = vbNullString Then
If BestandsSysteem().FileExists(InstellingenPad) Then
ProgrammaInstellingen = LaadInstellingen(InstellingenPad)
Else
Bericht = "Kan het instellingenbestand niet vinden." & vbCr
Bericht = Bericht & "Instellingenbestand: " & InstellingenPad & vbCr
Bericht = Bericht & "Dit bestand genereren?" & vbCr
Bericht = Bericht & "Huidig pad: " & CurDir$()
If MsgBox(Bericht, vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then
BewaarInstellingen InstellingenPad, StandaardInstellingen(), "De standaardinstellingen zijn weggeschreven naar:"
ProgrammaInstellingen = LaadInstellingen(InstellingenPad)
End If
End If
End If
EindeProcedure:
Instellingen = ProgrammaInstellingen
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure toont instellingsbestand gerelateerde foutmeldingen.
Private Function InstellingenFout(Bericht As String, Optional InstellingenPad As String = vbNullString, Optional Sectie As String = vbNullString, Optional Regel As String = vbNullString, Optional Fataal As Boolean = False) As Long
On Error GoTo Fout
Dim Keuze As Long
Dim Stijl As Long
If Not Sectie = vbNullString Then Bericht = Bericht & vbCr & "Sectie: " & Sectie
If Not Regel = vbNullString Then Bericht = Bericht & vbCr & "Regel: " & """" & Regel & """"
If Not InstellingenPad = vbNullString Then Bericht = Bericht & vbCr & "Instellingenbestand: " & InstellingenPad
Stijl = vbExclamation
If Not Fataal Then Stijl = Stijl Or vbOKCancel Or vbDefaultButton1
Keuze = MsgBox(Bericht, Stijl)
EindeProcedure:
InstellingenFout = Keuze
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure geeft aan of een interactieve batch moet worden afgebroken.
Public Function InteractieveBatchAfbreken(Optional BatchAfbreken As Variant) As Boolean
On Error GoTo Fout
Static Afbreken As Boolean
If Not IsMissing(BatchAfbreken) Then Afbreken = CBool(BatchAfbreken)
EindeProcedure:
InteractieveBatchAfbreken = Afbreken
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure geeft aan of de interactieve batchmodus actief is.
Public Function InteractieveBatchModusActief() As Boolean
On Error GoTo Fout
EindeProcedure:
InteractieveBatchModusActief = Instellingen().BatchInteractief And BatchModusActief()
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure beheert de interactieve batch parameters.
Private Function InteractieveBatchParameters(Optional Index As Long = 0, Optional NieuweParameter As Variant, Optional Verwijderen As Boolean = False) As String
On Error GoTo Fout
Static Parameters As New Collection
If Not IsMissing(NieuweParameter) Then
Parameters.Add CStr(NieuweParameter)
ElseIf Verwijderen Then
Set Parameters = New Collection
End If
EindeProcedure:
If Parameters.Count = 0 Then
InteractieveBatchParameters = vbNullString
Else
InteractieveBatchParameters = Parameters(Index + 1)
End If
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure geeft aan of de opgegeven regel een instellingen sectie naam bevat.
Private Function IsInstellingsSectie(Regel As String) As Boolean
On Error GoTo Fout
EindeProcedure:
IsInstellingsSectie = (Left$(Trim$(Regel), 1) = SECTIE_NAAM_BEGIN And Right$(Trim$(Regel), 1) = SECTIE_NAAM_EINDE)
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure geeft aan of het opgegeven datatype links uitgelijnd moet worden.
Private Function IsLinksUitgelijnd(DataType As Long) As Boolean
On Error GoTo Fout
Dim LinksUitgelijnd As Boolean
Dim TypeIndex As Long
LinksUitgelijnd = False
For TypeIndex = LBound(LinksUitgelijndeDataTypes()) To UBound(LinksUitgelijndeDataTypes())
If DataType = LinksUitgelijndeDataTypes(TypeIndex) Then
LinksUitgelijnd = True
Exit For
End If
Next TypeIndex
EindeProcedure:
IsLinksUitgelijnd = LinksUitgelijnd
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure voegt het opgegeven item toe aan de opgegeven lijst indien deze nog niet voorkomt.
Private Function ItemIsUniek(ByRef Lijst As Collection, Optional Item As Variant, Optional ResetLijst As Boolean = False) As Boolean
On Error GoTo Fout
Dim Index As Long
Dim Uniek As Boolean
Uniek = True
If ResetLijst Then
Set Lijst = New Collection
ElseIf Not IsMissing(Item) Then
For Index = 1 To Lijst.Count
If Lijst(Index) = Item Then
Uniek = False
Exit For
End If
Next Index
If Uniek Then Lijst.Add Item
End If
EindeProcedure:
ItemIsUniek = Uniek
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure laadt de instellingen voor dit programma.
Private Function LaadInstellingen(InstellingenPad As String) As InstellingenDefinitie
On Error GoTo Fout
Dim Afbreken As Boolean
Dim BestandsHandle As Long
Dim ParameterNaam As String
Dim ProgrammaInstellingen As InstellingenDefinitie
Dim RecensteGeldigeSectie As String
Dim Regel As String
Dim Sectie As String
Dim VerbindingsInformatie As String
Dim VerwerkteParameters As New Collection
Dim VerwerkteSecties As New Collection
Afbreken = False
ItemIsUniek VerwerkteParameters, , ResetLijst:=True
ItemIsUniek VerwerkteSecties, , ResetLijst:=True
ProgrammaInstellingen = StandaardInstellingen()
RecensteGeldigeSectie = vbNullString
Sectie = vbNullString
With ProgrammaInstellingen
.Bestand = InstellingenPad
BestandsHandle = FreeFile()
Open .Bestand For Input Lock Read Write As BestandsHandle
Do Until EOF(BestandsHandle) Or Afbreken
Line Input #BestandsHandle, Regel
If Not Left$(Trim$(Regel), 1) = COMMENTAAR_TEKEN Then
If IsInstellingsSectie(Regel) Then
Regel = Trim$(Regel)
RecensteGeldigeSectie = Sectie
Sectie = UCase$(Mid$(Regel, Len(SECTIE_NAAM_BEGIN) + 1, Len(Regel) - (Len(SECTIE_NAAM_BEGIN) + Len(SECTIE_NAAM_EINDE))))
If Not ItemIsUniek(VerwerkteSecties, Sectie) Then
If InstellingenFout("Sectie is meerdere keren aanwezig.", InstellingenPad, Sectie, Regel) = vbCancel Then Afbreken = True
End If
ItemIsUniek VerwerkteParameters, , ResetLijst:=True
Else
Select Case Sectie
Case "BATCH", "EXPORT", "QUERY", "VOORBEELD"
If Not Trim$(Regel) = vbNullString Then
LeesParameter Regel, ParameterNaam
If Not ItemIsUniek(VerwerkteParameters, ParameterNaam) Then
If InstellingenFout("Parameter is meerdere keren aanwezig.", InstellingenPad, Sectie, Regel) = vbCancel Then Afbreken = True
End If
End If
End Select
End If
Select Case Sectie
Case "BATCH"
If Not (IsInstellingsSectie(Regel) Or Trim$(Regel) = vbNullString) Then
If Not VerwerkBatchInstellingen(Regel, Sectie, ProgrammaInstellingen) Then Afbreken = True
End If
Case "EMAILTEKST"
If Not IsInstellingsSectie(Regel) Then .EMailTekst = .EMailTekst & Regel & vbCrLf
Case "EXPORT"
If Not (IsInstellingsSectie(Regel) Or Trim$(Regel) = vbNullString) Then
If Not VerwerkExportInstellingen(Regel, Sectie, ProgrammaInstellingen) Then Afbreken = True
End If
Case "QUERY"
If Not (IsInstellingsSectie(Regel) Or Trim$(Regel) = vbNullString) Then
If Not VerwerkQueryInstellingen(Regel, Sectie, ProgrammaInstellingen) Then Afbreken = True
End If
Case "VERBINDING"
If Not (IsInstellingsSectie(Regel) Or Trim$(Regel) = vbNullString) Then .VerbindingsInformatie = .VerbindingsInformatie & Trim$(Regel)
Case "VOORBEELD"
If Not (IsInstellingsSectie(Regel) Or Trim$(Regel) = vbNullString) Then
If Not VerwerkVoorbeeldInstellingen(Regel, Sectie, ProgrammaInstellingen) Then Afbreken = True
End If
Case Else
If Not Trim$(Regel) = vbNullString Then
If IsInstellingsSectie(Regel) Then
Sectie = RecensteGeldigeSectie
If InstellingenFout("Niet herkende sectie.", InstellingenPad, Sectie, Regel) = vbCancel Then Afbreken = True
Else
If InstellingenFout("Niet herkende parameter.", InstellingenPad, Sectie, Regel) = vbCancel Then Afbreken = True
End If
End If
End Select
End If
Loop
Close BestandsHandle
If Trim$(.VerbindingsInformatie) = vbNullString And Not Afbreken Then
VerbindingsInformatie = Trim$(VraagVerbindingsInformatie())
If Not VerbindingsInformatie = vbNullString Then
.VerbindingsInformatie = VerbindingsInformatie
BewaarInstellingen InstellingenPad, ProgrammaInstellingen, "De instellingen zijn weggeschreven naar:"
End If
End If
.VerbindingsInformatie = MaakVerbindingsInformatieOp(.VerbindingsInformatie)
End With
EindeProcedure:
Close BestandsHandle
LaadInstellingen = ProgrammaInstellingen
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False, TypePad:="Instellingenbestand: ", Pad:=InstellingenPad) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure stuurt de waarde en de naam van een instellingen parameter in de opgegeven regel terug.
Private Function LeesParameter(Regel As String, ByRef ParameterNaam As String) As String
On Error GoTo Fout
Dim Positie As Long
Dim Waarde As String
ParameterNaam = vbNullString
Waarde = vbNullString
Positie = InStr(Regel, WAARDE_TEKEN)
If Positie > 0 Then
ParameterNaam = LCase$(Trim$(Left$(Regel, Positie - 1)))
Waarde = Trim$(Mid$(Regel, Positie + 1))
End If
EindeProcedure:
LeesParameter = Waarde
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure stuurt een lijst van databasedatatypes die linksuitgelijnd worden terug.
Private Function LinksUitgelijndeDataTypes() As Variant
On Error GoTo Fout
EindeProcedure:
LinksUitgelijndeDataTypes = Array(adBSTR, adChar, adDBDate, adDBTime, adDBTimeStamp, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar)
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure maakt de opgegeven foutomschrijving op.
Private Function MaakFoutOmschrijvingOp(FoutOmschrijving As String) As String
On Error Resume Next
Dim Omschrijving As String
Omschrijving = Trim$(FoutOmschrijving)
Do
Select Case Right$(Omschrijving, 1)
Case vbCr, vbLf
Omschrijving = Trim$(Left$(Omschrijving, Len(Omschrijving) - 1))
Case Else
Exit Do
End Select
Loop
If Not Right$(Omschrijving, 1) = "." Then Omschrijving = Omschrijving & "."
MaakFoutOmschrijvingOp = Omschrijving
End Function
'Deze procedure controleert de opgegeven verbindingsinformatie en maakt deze op.
Private Function MaakVerbindingsInformatieOp(VerbindingsInformatie As String) As String
On Error GoTo Fout
Dim HuidigStringTeken As String
Dim OpgemaakteVerbindingsInformatie As String
Dim Parameter As String
Dim ParameterBegin As Long
Dim ParameterNaam As String
Dim ParameterNamen As Collection
Dim Positie As Long
Dim Teken As String
Dim Waarde As String
OpgemaakteVerbindingsInformatie = vbNullString
If Not Trim$(VerbindingsInformatie) = vbNullString Then
HuidigStringTeken = vbNullString
ItemIsUniek ParameterNamen, , ResetLijst:=True
Positie = 1
ParameterBegin = Positie
If Not Right$(Trim$(VerbindingsInformatie), Len(VERBINDING_PARAMETER_TEKEN)) = VERBINDING_PARAMETER_TEKEN Then VerbindingsInformatie = VerbindingsInformatie & VERBINDING_PARAMETER_TEKEN
Do Until Positie > Len(VerbindingsInformatie)
Teken = Mid$(VerbindingsInformatie, Positie, 1)
If InStr(TEKENREEKS_TEKENS, Teken) > 0 Then
If HuidigStringTeken = vbNullString Then
HuidigStringTeken = Teken
ElseIf Teken = HuidigStringTeken Then
HuidigStringTeken = vbNullString
End If
ElseIf Teken = VERBINDING_PARAMETER_TEKEN Then
If HuidigStringTeken = vbNullString Then
Parameter = Mid$(VerbindingsInformatie, ParameterBegin, Positie - ParameterBegin)
If InStr(Parameter, WAARDE_TEKEN) = 0 Then
OpgemaakteVerbindingsInformatie = vbNullString
MsgBox "Ongeldige parameter aanwezig in verbindingsinformatie: """ & Parameter & """. Verwacht teken: " & WAARDE_TEKEN, vbExclamation
Exit Do
End If
Waarde = LeesParameter(Parameter, ParameterNaam)
If Not ItemIsUniek(ParameterNamen, ParameterNaam) Then
OpgemaakteVerbindingsInformatie = vbNullString
MsgBox "Parameter meerdere malen aanwezig in verbindingsinformatie: """ & Parameter & """.", vbExclamation
Exit Do
End If
ParameterBegin = Positie + 1
OpgemaakteVerbindingsInformatie = OpgemaakteVerbindingsInformatie & ParameterNaam & WAARDE_TEKEN & Trim$(Waarde) & VERBINDING_PARAMETER_TEKEN
End If
End If
Positie = Positie + 1
Loop
If Not HuidigStringTeken = vbNullString Then
OpgemaakteVerbindingsInformatie = vbNullString
MsgBox "Niet afgesloten tekenreekswaarde in verbindingsgegevens. Verwacht teken: " & HuidigStringTeken, vbExclamation
End If
End If
EindeProcedure:
MaakVerbindingsInformatieOp = OpgemaakteVerbindingsInformatie
Exit Function
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Function
'Deze procedure wordt uitgevoerd wanneer het programma wordt gestart.
Private Sub Main()
On Error GoTo Fout
Dim InstellingenPad As String
ControleerOpAPIFout SetCurrentDirectoryA(Left$(App.Path, InStr(App.Path, ":")))
ChDir App.Path
With OpdrachtRegelParameters(Command$())
If .Verwerkt Then
If Left$(Trim$(.InstellingenPad), Len(PARAMETER_TEKEN)) = PARAMETER_TEKEN Then
InstellingenPad = VerwijderAanhalingsTekens(Mid$(Trim$(.InstellingenPad), Len(PARAMETER_TEKEN) + 1))
If InstellingenPad = vbNullString Then
MsgBox "Kan de instellingen niet bewaren. Geen doel bestand opgegeven.", vbExclamation
Else
BewaarInstellingen InstellingenPad, StandaardInstellingen(), "De standaardinstellingen zijn weggeschreven naar:"
End If
ElseIf Not .SessiesPad = vbNullString Then
SessieParameters , , Verwijderen:=True
VerwerkSessieLijst .SessiesPad
Else
SessieParameters , , Verwijderen:=True
VoerSessieUit Command$()
End If
End If
End With
EindeProcedure:
Verbinding , VerbindingSluiten:=True
SluitAlleVensters
Exit Sub
Fout:
If HandelFoutAf(VraagVorigeKeuzeOp:=False) = vbIgnore Then Resume EindeProcedure
If HandelFoutAf() = vbRetry Then Resume
End Sub
'Deze procedure controleert de queryparameter invoer en stuurt eventueel de index van een onjuist ingevuld veld en een fout omschrijving terug.
Private Function OngeldigeParameterInvoer(Optional ByRef FoutInformatie As String = vbNullString) As Long