-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathcDataTable.cls
4856 lines (3833 loc) · 171 KB
/
cDataTable.cls
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
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cDataTable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Base 1
'Option Compare Text
'# <author> Daniel Grass
'# <mail> [email protected]
'#Region
'# Public Subs, Functions and Properties
'#======================================================================================================================
'# Accessible in this class
'#======================================================================================================================
' |> Get | --- About :: Returns description of the class.
' |> --------- CreateLogFile :: Creates a logfile for output and stores it in the specified [storageDirectory].
' |> Get | Let DirectoryPath :: Returns the directory location of the current logfile.
' |> Get | --- Name :: Returns name of the data table (Default Property).
' |> Get | --- Version :: Returns version string for the class [e.g. #.# (year)].
'#======================================================================================================================
'# Usage
'#======================================================================================================================
'
'
'----------------------------------------------
'#======================================================================================================================
'# References
'#======================================================================================================================
#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#If Win64 Then
Private Const PTR_LENGTH As Long = 8
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub Mem_Copy Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function ArrayPtr Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
'Private Declare PtrSafe Sub PutMem4 Lib "VBE7" (ByVal Ptr As LongPtr, ByVal Value As LongPtr)
Private Declare PtrSafe Sub PutMem4 Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 8)
'Private Declare PtrSafe Function ArrayPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As LongPtr
'Private Declare PtrSafe Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As LongPtr, ByVal Value As LongPtr)
Private Declare PtrSafe Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As LongPtr, saBound As Long) As LongPtr
#Else
Private Const PTR_LENGTH As Long = 4
Private Declare Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Private Declare Sub Mem_Copy Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As LongPtr)
Private Declare Function ArrayPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long
#End If
'#======================================================================================================================
'# Dependencies to other classes
'#======================================================================================================================
' cIndex :: is a single Index of a data column
' cHashTable (thourgh cIndex as well) :: is used to access column indices & as underlying data structure
' to unique indices
' cBPlusTree (thourgh cIndex) :: is used as underlying data structure to non-unique indices
'#======================================================================================================================
'# Application Constants, Enumerations & Types
'#======================================================================================================================
#Const C_CON_OFFICE_APP = "XLS" '##### CHANGE THIS TO ANYTHING ELSE THEN 'XLS' WHEN NOT USING THIS CLASS IN EXCEL #####
Const C_WANT_FREE_PERCENT = 0.1 ' 0.1 translates in 10% free space
Const C_MIN_FREE = 10 ' Min unused space when resizing
Const C_MAX_WAIT_CYCLES = 100 ' Number of iterations to check if object is locked before throwing time out error
Const C_WAIT_TIME_MS = 100 ' Number of milliseconds to wait for next check if object is locked
Private Const C_CUT_OFF As Long = 100 'move into Insertionsort if list (or sublist) has less 100 items
Private Const C_Name As String = "cDataTable"
Public Enum MatchType
Equals = 1
DoesNotEqual = 2
MatchesPattern = 3
DoesNotMatchPattern = 4
GreaterThen = 5
GreaterThenOrEqual = 6
LessThen = 7
LessThenOrEqual = 8
End Enum
Public Enum OutputType
OverwriteIfExists = 1
AppendIfExists = 2
ErrorIfExists = 3
End Enum
Public Enum AggregateFunction
aggFctMin = 1
aggFctMax = 2
aggFctSum = 3
aggFctAvg = 4
accFctCount = 5
aggFctMedian = 6
aggFctMean = 7
aggFctPctl = 8
End Enum
Public Enum SelectionType
selectFields = 1
selectRow = 2
End Enum
Public Enum AppendType
appendMatchingFieldsOnly = 1
appendAndCreateMissingFields = 2
End Enum
Private Enum ResizeType
IncludingWantFreeSpace = 1
WithoutEmptyTrailRecords = 2
End Enum
Private Enum ColumnType
dtNull = vbNull
dtInteger = vbInteger
dtLong = vbLong
dtSingle = vbSingle
dtDouble = vbDouble
dtCurrency = vbCurrency
dtDate = vbDate
dtString = vbString
dtObject = vbObject
dtError = vbError
dtBoolean = vbBoolean
dtVariant = vbVariant
dtDataObject = vbDataObject
dtDecimal = vbDecimal
dtByte = vbByte
dtUserDefinedType = vbUserDefinedType
dtArray = vbArray
End Enum
Private Type DataColumn
Number As Long
name As String
Type As ColumnType
IsSorted As Boolean
IsIndexed As Boolean
index As cIndex
End Type
Private Type ErrorCode
errNumber As Long
errDescrption As String
End Type
'#======================================================================================================================
'# API Constants, Enumerations & Types
'#======================================================================================================================
'Type Declarations needed for SafeArray hacks
'The bounds of the SafeArray
Private Type SafeArrayBound
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
Bounds(0 To 0) As SafeArrayBound
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
Bounds(0 To 1) As SafeArrayBound
End Type
'#======================================================================================================================
'# Private Variables
'#======================================================================================================================
Private m_Name As String ' The name of the data table
Private m_DataSource As Variant ' A reference to the data source
Private m_List() As Variant ' The list array.
Private m_IdxToList() As Long ' The index table to access the list array
Private m_ListTransposed() As Variant ' The transposed list array
Private m_NumCols As Long ' Number of Columns
Private m_NumRecs As Long ' Number of Records
Private m_NumItems As Long ' Last index in use.
Private m_ArraySize As Long ' Size of the list array.
Private m_ShrinkWhen As Long ' Shrink if m_NumItems < this.
Private m_GarbageCount As Long ' The number of garbage entries.
Private m_MaxGarbage As Long ' Collect when m_GarbageCount > this.
Private m_FirstGarbage As Long ' The index of the 1st record containing garbage
Private m_LastGarbage As Long ' The index of the last record containing garbage
Private m_CollectGarbage As Boolean ' Flag to determine if we should collect garbage
Private m_EnableObjects As Boolean ' Flag to determine if we allow objects to be stored
Private m_PreserveNumberStoredAsText As Boolean ' Flag to determine if numbers stored as text should be preserved in this form
Private m_Columns() As DataColumn ' Array containing the data columns
Private m_SearchLastItem As Variant ' The last item that was searched
Private m_SearchLastColumn As Long ' Contains the column index of the column last searched
Private m_Bookmark As Long ' Bookmark pointing to the current record
Private m_HasHeaders As Boolean ' Indicates if column headers were provided
Private m_IsDirty As Boolean ' Indicates if the array needs cleanup and a refresh of the transposed list
Private m_IsLocked As Boolean ' Indicates if the class is currently being updated
Private m_IsIndexed As Boolean ' Indicates if the class has at least one active index
Private m_BOF As Boolean ' Indicates that the cursor has reached the beginning of the table
Private m_EOF As Boolean ' Indicates that the cursor has reached the end of the table
Private m_CopyCount As Long ' Internal counter to keep track of the number of copies made of this data table
Private m_Errors(1 To 14) As ErrorCode ' List of all error codes
'#Region
'#======================================================================================================================
'# Class Initialization, Termination & Properties
'#======================================================================================================================
Private Sub Class_Initialize()
' ************************************************
' Class constructor.
' ************************************************
'Debug.Print "|> Initializing:= " & Me.Name
'Set list to minimal size
ReDim m_List(1, 1)
ReDim m_IdxToList(1 To 1)
'set the default name and data source
m_Name = "DataTable"
m_DataSource = "None"
'initialze the boolean states
m_HasHeaders = False
m_IsDirty = False
m_CollectGarbage = True
m_EnableObjects = False
m_PreserveNumberStoredAsText = False
m_EOF = False
m_BOF = False
m_IsLocked = False
m_IsIndexed = False
'initialize any default / start values
m_NumCols = 1
m_Bookmark = -1
m_FirstGarbage = 1
m_LastGarbage = 1
m_CopyCount = 0
'initialize error codes
m_Errors(1).errNumber = 513: m_Errors(1).errDescrption = "List is not empty. Range can only be added to empty list!"
m_Errors(2).errNumber = 514: m_Errors(2).errDescrption = "The list of Header Names does not match the number of columns you specified!"
m_Errors(3).errNumber = 515: m_Errors(3).errDescrption = "The no of items in the input record does not match the number of columns in the data table!"
m_Errors(4).errNumber = 516: m_Errors(4).errDescrption = "Assigning a value to an item out of boundaries of the data table is not possible!"
m_Errors(5).errNumber = 517: m_Errors(5).errDescrption = "The column name you specified could not be found in the data table!"
m_Errors(6).errNumber = 518: m_Errors(6).errDescrption = "Accessing an item needs either a row number or an active cursor from one of the RsXxxx methods!"
m_Errors(7).errNumber = 519: m_Errors(7).errDescrption = "The two defined tables do not have the same data structure. Cannot append two tables with different data strucutres!"
m_Errors(8).errNumber = 520: m_Errors(8).errDescrption = "No of records in Data Table exeed excel row limit! Use compression mode to output bigger data sets."
m_Errors(9).errNumber = 901: m_Errors(9).errDescrption = "Timeout/Deadlock - the data table is locked for update, time limit exeeded!"
m_Errors(10).errNumber = 521: m_Errors(10).errDescrption = "Output File already exists!"
m_Errors(11).errNumber = 522: m_Errors(11).errDescrption = "Record exeeds no of columns defined for this table. Can't append the data!"
m_Errors(12).errNumber = 523: m_Errors(12).errDescrption = "RSFindNext does not work for columns with a unique index! Please use RSFindFirst instead."
m_Errors(13).errNumber = 524: m_Errors(13).errDescrption = "Column name '[COLUMN_NAME]'count not be found!"
m_Errors(14).errNumber = 525: m_Errors(14).errDescrption = "Dumping to target worksheet led to the following error: "
End Sub
Private Sub Class_Terminate()
' ************************************************
' Class destructor.
' ************************************************
Dim ptrList As Long
Dim ptrListTransposed As Long
'Debug.Print "|> Terminating:= " & Me.Name
'empty the list
ReDim m_List(1, 1)
ReDim m_ListTransposed(1, 1)
End Sub
Public Property Get Version() As String
' ************************************************
' Version string of the current class.
' Contains a list of (historical) changes to the class within the comments of the procedure.
' ************************************************
'Version = "Version 1.0.0.0 (2017)" 'Initial release
'Version = "Version 1.0.1.0 (06/2017)" 'Including bug fixes for garbage collection and output to excel
'Version = "Version 1.1.0.0 (06/2017)" 'Including features to make class thread save
'Version = "Version 1.2.0.0 (12/2017)" 'Including new features on columns and 1st version of indexing
'Version = "Version 1.2.1.0 (01/2018)" 'Including x64 compatibility
'Version = "Version 1.2.2.1 (01/2018)" 'Fixed pattern matching and SortUnstable
'Version = "Version 1.2.2.2 (02/2018)" 'Fixed RecordAdd to handle both arrays and ParamArray
'Implement enabling of object storage
'Version = "Version 1.2.3.0 (01/2019)" 'Added 1st version of maintenance of indices
'Version = "Version 1.2.3.1 (05/2019)" 'Fixed WriteToCell with additional checks for wrapped output
'Version = "Version 1.2.3.2 (01/2020)" 'Fixed m_GarbageCount reset at the end of CollectGarbage procedure
'Version = "Version 1.2.3.2 (01/2020)" 'Fixing x64 compatibility in functions using CopyMemory
'Version = "Version 1.2.3.3 (04/2020)" 'Fixing of x64 compatibility in functions using CopyMemory did not work with "Transpose", hence implemented a quick fix using classic transpose for x64
'Version = "Version 1.2.3.4 (08/2020)" 'Fixing of x64 compatibility in functions using CopyMemory did not work with "SplitCSV", hence implemented a completely new CSV parser based on byte array processing (for better speed)
'Version = "Version 1.2.4.0 (10/2020)" 'Added new features to copy the table structure (but not the data) and to be able to slect a distinct set of data for a given list of columns
'Added enhanced error handling for RSFindNext in combination with unique indexed columns as well as unknown column names to prevent "slient missbehaviour"
'Version = "Version 1.2.5.0 (07/2021)" 'Added new properties to check if column exists and to set a column name
'Version = "Version 1.2.5.1 (09/2021)" 'Bug fix in the ParseCSV003 procedure to poperly process quoted strings
'Version = "Version 1.2.5.2 (09/2021)" 'Bug fix: m_NumItems is "out of sync" when records are deleted but garbage collection has not happened yet
'to fix this a new attribute m_NumRecs / RecordCount was introduced, being maintained on creation and deletion of records
'finally to remain consistent a new attribute ColumnCount was introduced as well
'Version = "Version 1.2.6.0 (09/2021)" 'Added new methods ColumnsAdd and AppendToTable
'Version = "Version 1.2.7.0 (10/2021)" 'Finished maintenance of indices (including RemoveRecord and CollectGarbage), i.e. completed indexing for unique indices
'Version = "Version 1.2.7.1 (03/2022)" 'Bug fix: Setting SortedColumn was missing in SortUnstable
'Version = "Version 1.2.7.2 (04/2022)" 'Bug fix: use move row instead of manual loop in CollectGarbage
'Version = "Version 1.2.8.0 (07/2022)" 'Enhanced LoadRange to create empty table if only header is provided
'Added property "ItemIndex" which returns the numeric index of a named Item
'Version = "Version 1.2.8.1 (09/2022)" 'Bugfix in LoadRange when empty table if only header is provided
'Bugfix in DumpToRange error handling to avaid silent errors
'Version = "Version 1.2.8.2 (10/2023)" 'Added new feature to consider filters in LoadRange
Version = "Version 1.2.9.0 (10/2024)" 'Added new feature to clone (i.e. create a deep copy of) the data table
End Property
Public Property Get About() As String
' ***********************************************
' String that describes the current class.
' ***********************************************
About = "Data Table Class providing advanced array based data handling. Version: " & Me.Version & "." & VBA.vbCrLf & VBA.vbCrLf
About = About & "For additional details please contact the author."
End Property
Public Property Get ClassName() As String
' ***********************************************
' Returns the name of the class.
' ***********************************************
ClassName = C_Name
End Property
Public Property Get name() As String
' ***********************************************
' Returns the name of the data table.
' ***********************************************
name = m_Name
End Property
Public Property Let name(value As String)
' ***********************************************
' Sets the name of the data table.
' ***********************************************
m_Name = value
End Property
Public Property Get Headers() As Collection
' ***********************************************
' Returns the headers of the table as collection
' ***********************************************
Dim cHeaders As New Collection
Dim i As Long
For i = LBound(m_Columns) To UBound(m_Columns)
cHeaders.Add m_Columns(i).name
Next i
Set Headers = cHeaders
End Property
Public Property Get HeaderList(Optional IncludeTableName As Boolean = False) As String
Dim vHead As Variant
Dim stHL As String
For Each vHead In Headers
If IncludeTableName = False Then
stHL = stHL & vHead & ", "
Else
stHL = stHL & m_Name & "." & vHead & ", "
End If
Next
stHL = Left$(stHL, Len(stHL) - 2)
HeaderList = stHL
End Property
Public Property Get HasHeaders() As Boolean
' ***********************************************
' Returns the HasHeaders state of the class.
' ***********************************************
HasHeaders = m_HasHeaders
End Property
Friend Property Let HasHeaders(bValue As Boolean)
'***********************************************
'Sets the HasHeaders state of the class.
'***********************************************
m_HasHeaders = bValue
End Property
Public Property Get NumItems() As Long
' ***********************************************
' Return the number of records.
' Replaced by RecordsCount but left for backward
' compatability
' ***********************************************
NumItems = m_NumRecs
End Property
Public Property Get NumCols() As Long
' ***********************************************
' Return the number of columns.
' Replaced by ColumnsCount but left for backward
' compatability
' ***********************************************
NumCols = m_NumCols
End Property
Public Property Get ColumCount() As Long
' ***********************************************
' Return the number of records.
' ***********************************************
ColumCount = m_NumCols
End Property
Public Property Get RecordCount() As Long
' ***********************************************
' Return the number of records.
' ***********************************************
RecordCount = m_NumRecs
End Property
Private Property Get ArraySize() As Long
' ***********************************************
' Return the size of the array.
' ***********************************************
ArraySize = m_ArraySize
End Property
Public Property Get GarbageCollection() As Boolean
' ***********************************************
' Returns the CollectGarbage state of the class.
' ***********************************************
GarbageCollection = m_CollectGarbage
End Property
Public Property Let GarbageCollection(value As Boolean)
' ***********************************************
' Sets the CollectGarbage state of the class.
' ***********************************************
If value = False Then
'Set the state to false
m_CollectGarbage = False
Else
'set the state to true
m_CollectGarbage = True
'If table is dirty, collect garbage
If m_IsDirty = True Then
CollectGarbage
End If
End If
End Property
Public Property Get ObjectStorageEnabled() As Boolean
' ***********************************************
' Returns the ObjectStorageEnabled state of the class.
' ***********************************************
ObjectStorageEnabled = m_EnableObjects
End Property
Public Property Let ObjectStorageEnabled(value As Boolean)
' ***********************************************
' Sets the ObjectStorageEnabled state of the class.
' ***********************************************
m_EnableObjects = value
End Property
Public Property Get PreserveNumberStoredAsText() As Boolean
' ***********************************************
' Returns the PreserveNumberStoredAsText state of the class.
' ***********************************************
PreserveNumberStoredAsText = m_PreserveNumberStoredAsText
End Property
Public Property Let PreserveNumberStoredAsText(value As Boolean)
' ***********************************************
' Sets the PreserveNumberStoredAsText state of the class.
' ***********************************************
m_PreserveNumberStoredAsText = value
End Property
Public Property Get TableSummary() As String
' ***********************************************
' This displays a summary of the table
' ## This is the default property ##
' ***********************************************
TableSummary = "Table Name: " & m_Name & vbCrLf & _
"No of Columns: " & m_NumCols & vbCrLf & _
"No of Records: " & m_NumRecs & vbCrLf & _
"Objects enabled: " & m_EnableObjects & vbCrLf & _
"Gargabe Collection: " & m_CollectGarbage & vbCrLf & _
"Bookmark: " & m_Bookmark & vbCrLf & _
"Beginning of File: " & m_BOF & vbCrLf & _
"End of File: " & m_EOF & vbCrLf & _
vbCrLf & _
"Columns: " & vbCrLf & _
Me.HeaderList
End Property
'Public Property Get SADescrPtr() As LongPtr
'' ***********************************************
'' Return the pointer to the SafeArray Descriptor
'' ***********************************************
'
'
' SADescrPtr = getSafeArrayDescrPtr(m_List)
'
'End Property
'
'Public Property Get SAStructPtr() As LongPtr
'' ***********************************************
'' Return the pointer to the SafeArray Descriptor
'' ***********************************************
'
'
' SAStructPtr = getSafeArrayStructPtr(m_List)
'
'End Property
Public Property Get RsEOF() As Boolean
' ***********************************************
' Return the EOF State of the recordset
' ***********************************************
RsEOF = m_EOF
End Property
Public Property Get RsBOF() As Boolean
' ***********************************************
' Return the EOF State of the recordset
' ***********************************************
RsBOF = m_BOF
End Property
Public Property Get RsBookmark() As Long
' ***********************************************
' Return the pointer to the current record within the recordset
' ***********************************************
RsBookmark = m_Bookmark
End Property
Public Property Let RsBookmark(value As Long)
' ***********************************************
' Set the pointer of the current record within the recordset
' to a specific position
' ***********************************************
If value > m_NumItems Then
m_EOF = True
Else
m_Bookmark = value
End If
End Property
Public Property Get ItemName(index As Long) As String
' ***********************************************
' Return the name of the Item (Column Header)
' ***********************************************
ItemName = GetColumnName(index)
End Property
Public Property Let ItemName(index As Long, value As String)
' ***********************************************
' Set the name of the Item (Column Header)
' ***********************************************
SetColumnName index, value
End Property
Public Property Get ItemIndex(name As String) As Long
' ***********************************************
' Return the index of the Item (Column Header)
' ***********************************************
Dim iCol As Long
iCol = GetColumnIndex(name)
If iCol = -1 Then
'Column Name not found. release the lock and raise an error (Return Null did lead to "silent missbehavior")
'ItemGet = Null
Err.Raise vbObjectError + m_Errors(13).errNumber, Me.name, Replace(m_Errors(13).errDescrption, "[COLUMN_NAME]", name)
Else
ItemIndex = iCol
End If
End Property
Public Property Get ItemExists(index As Variant) As Boolean
' ***********************************************
' Check if an Item (Column Header) exists
' ***********************************************
ItemExists = IsTableColumn(index)
End Property
Public Property Get ItemRaw(Row As Long, Column As Long) As Variant
' ***********************************************
' Return a given item at index / position
' No safety checks, no thread safety for max speed
' ***********************************************
ItemRaw = m_List(Column, Row)
End Property
Public Property Get Item(index As Variant, Optional Row As Long = -1) As Variant
' ***********************************************
' Return a given item at index / position
' ***********************************************
If Row = -1 And m_Bookmark = -1 Then
'release the lock and raise error as we need either of the information
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + m_Errors(6).errNumber, Me.name, m_Errors(6).errDescrption
ElseIf Row > -1 Then
'user provided a position, use this one
If m_EnableObjects = True Then
If IsObject(ItemGet(Row, CStr(index))) Then
Set Item = ItemGet(Row, CStr(index))
Else
Item = ItemGet(Row, CStr(index))
End If
Else
Item = ItemGet(Row, CStr(index))
End If
ElseIf m_Bookmark > -1 Then
'we have a valid bookmark so let's use this
If m_EnableObjects = True Then
If IsObject(ItemGet(m_Bookmark, CStr(index))) Then
Set Item = ItemGet(m_Bookmark, CStr(index))
Else
Item = ItemGet(m_Bookmark, CStr(index))
End If
Else
Item = ItemGet(m_Bookmark, CStr(index))
End If
Else
MsgBox "Unhandled condition in Property Get 'Item'", vbCritical
Exit Property
End If
End Property
Public Property Let Item(index As Variant, Optional Row As Long = -1, value As Variant)
' ***********************************************
' Set the value of a given item at position / index
' ***********************************************
If Row = -1 And m_Bookmark = -1 Then
'release the lock and raise error as we need either of the information
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + m_Errors(6).errNumber, Me.name, m_Errors(6).errDescrption
ElseIf Row > -1 Then
'user provided a position, use this one
Call ItemSet(Row, CStr(index), value)
ElseIf m_Bookmark > -1 Then
'we have a valid bookmark so let's use this
Call ItemSet(m_Bookmark, CStr(index), value)
Else
MsgBox "Unhandled condition in Property Let 'Item'", vbCritical
Exit Property
End If
End Property
Public Property Get Record(Optional Row As Long = -1) As Variant()
' ***********************************************
' Return an record from the list by position.
' ***********************************************
Dim iCol As Long
Dim tmpRec() As Variant
Dim Position As Long
If Row = -1 And m_Bookmark = -1 Then
'release the lock and raise error as we need either of the information
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + m_Errors(6).errNumber, Me.name, m_Errors(6).errDescrption
ElseIf Row > -1 Then
'user provided a position, use this one
Position = Row
ElseIf m_Bookmark > -1 Then
'we have a valid bookmark so let's use this
Position = m_Bookmark
Else
MsgBox "Unhandled condition in Property Get 'Record'", vbCritical
Exit Property
End If
If Position < 1 Or Position > m_NumItems Then
' Out of bounds. Return Null.
Record = Null
Else
ReDim tmpRec(1 To m_NumCols)
'For iCol = 1 To m_NumCols
' ' Return the record.
' tmpRec(iCol) = m_List(iCol, position)
'Next iCol
RecordRead tmpRec, Position
Record = tmpRec
End If
End Property
Public Property Let Record(Optional Row As Long = -1, Record() As Variant)
' ***********************************************
' Update a record in the list by position.
' ***********************************************
Dim iCol As Long
Dim tmpRec() As Variant
Dim Position As Long
If Row = -1 And m_Bookmark = -1 Then
'release the lock and raise error as we need either of the information
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + m_Errors(6).errNumber, Me.name, m_Errors(6).errDescrption
ElseIf Row > -1 Then
'user provided a position, use this one
Position = Row
ElseIf m_Bookmark > -1 Then
'we have a valid bookmark so let's use this
Position = m_Bookmark
Else
MsgBox "Unhandled condition in Property Let 'Record'", vbCritical
Exit Property
End If
If Position < 1 Or Position > m_NumItems Then
' Out of bounds, raise error and release the lock
' The range 513-65535 is available for user errors.
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + m_Errors(4).errNumber, Me.name, m_Errors(4).errDescrption
Else
If UBound(Record) = UBound(m_List, 1) Then
'handle thread safety
CheckLockStatus
LockForUpdate
'For iCol = 1 To m_NumCols
' ' Set the record values.
' m_List(iCol, position) = Record(iCol)
'Next iCol
RecordWrite Position, Record, 0
'handle thread safety
ReleaseLock
'mark as dirty
m_IsDirty = True
Else
'release the lock and raise error -> Not the same no of column Names as NoOfColumns specified
' The range 513-65535 is available for user errors.
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + 515, Me.name, "The no of items in the input record does not match the number of columns in the data table!"
End If
End If
End Property
'#Region
'#======================================================================================================================
'# Table Definition, Index Handling and Statistics
'#======================================================================================================================
Public Sub DefineTable(NoOfColumns As Long, Optional ColumnHeaders As String = "n/a", Optional NoOfRows As Long = 1)
' ***********************************************
' Define structure of array and create Header List
' ***********************************************
Dim i As Long
Dim aTmp As Variant
'Size the list
ReDim m_List(1 To NoOfColumns, 1 To NoOfRows)
m_ArraySize = NoOfRows
'fill in the Headers
ReDim m_Columns(1 To NoOfColumns)
'Name the Fields Field<n> if no field list is provided
If ColumnHeaders = "n/a" Or (NoOfColumns < 1 And InStr(ColumnHeaders, ",") = 0) Then
For i = 1 To NoOfColumns
m_Columns(i).name = "Field" & i
m_Columns(i).Number = i
m_Columns(i).IsSorted = False
m_Columns(i).IsIndexed = False
m_Columns(i).Type = dtVariant
Next i
m_NumCols = NoOfColumns
ElseIf InStr(ColumnHeaders, ",") > 0 Then
aTmp = Split(ColumnHeaders, ",")
If UBound(aTmp) + 1 = NoOfColumns Then
For i = 1 To UBound(aTmp) + 1
m_Columns(i).name = Trim(aTmp(i - 1))
m_Columns(i).Number = i
m_Columns(i).IsSorted = False
m_Columns(i).IsIndexed = False
m_Columns(i).Type = dtVariant
Next i
m_NumCols = NoOfColumns
m_HasHeaders = True
Else
' release the lock and raise error -> Not the same no of column Names as NoOfColumns specified
' The range 513-65535 is available for user errors.
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + 514, Me.name, "The list of Header Names does not match the number of columns you specified!"
End If
ElseIf ColumnHeaders <> "n/a" And NoOfColumns = 1 Then
'table with a single named column
i = 1
m_Columns(i).name = ColumnHeaders
m_Columns(i).Number = 1
m_Columns(i).IsSorted = False
m_Columns(i).IsIndexed = False
m_Columns(i).Type = dtVariant
m_NumCols = NoOfColumns
m_HasHeaders = True
Else
' releaes the lock and raise error -> Not the same no of column Names as NoOfColumns specified
' The range 513-65535 is available for user errors.
' For class errors, you add vbObjectError to the error number.
ReleaseLock
Err.Raise vbObjectError + 514, Me.name, "The list of Header Names does not match the number of columns you specified!"
End If
End Sub
Public Function Clone() As cDataTable
' ***********************************************
' Create a deep copy of the data table
' ***********************************************
Dim tOut As cDataTable
Set tOut = Me.CreateEmptyCopy
tOut.AppendToTable Me
Set Clone = tOut
End Function
Public Function CreateEmptyCopy() As cDataTable
' ***********************************************
' Create an empty copy of the data table
' ***********************************************
Dim tOut As cDataTable
'copy the structure of the data table
Set tOut = New cDataTable
tOut.DefineTable m_NumCols, Me.HeaderList, m_NumItems
'copy the important properties
m_CopyCount = m_CopyCount + 1
With tOut
.GarbageCollection = m_CollectGarbage
.HasHeaders = m_HasHeaders
.name = m_Name & "_" & m_CopyCount
.ObjectStorageEnabled = m_EnableObjects
End With