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
'**********************************************************************************************************
' Name: getRecordsetAsArray
' Author: mielk | 2012-09-15
'
' Comment: Function fetches the data based on the given SQL string and using the given
' connection and returns them as a two-dimensional array.
'
' Parameters:
' connection Connection used to communicate with the database.
' It must be object of ADODB.Connection class, otherwise error will be thrown.
' sqlString SQL command used for fetching data.
' includeHeaders Determines if the results array should contain headers row.
' * By default headers row is included in the result array.
'
'
' Returns:
' Variant Array representing recordset returned by the query given
' as a parameter.
'
'
' Exceptions:
' ConnectionException Thrown if the given parameter [connection] is not of ADODB.Connection
' class or if it is closed.
' SQLException Thrown if the given SQL query could not been executed for any reason.
'
'
' --- Changes log -----------------------------------------------------------------------------------------
' 2012-09-15 mielk Class created.
'**********************************************************************************************************
Public Function getRecordsetAsArray(connection As Object, sqlString As String, _
Optional includeHeaders As Boolean = False) As Variant
Const METHOD_NAME As String = "getRecordsetAsArray"
'------------------------------------------------------------------------------------------------------
'This value is used for rediming result array.
Const REDIM_STEP As Long = 1000
'------------------------------------------------------------------------------------------------------
Dim results() As Variant
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim row As Long
Dim column As Integer
Dim columns As Integer
'------------------------------------------------------------------------------------------------------
'Check if the given connection is defined and open. -------------------------------------------------|
If Not TypeOf connection Is ADODB.connection Then GoTo ConnectionException '|
If connection Is Nothing Then GoTo ConnectionException '|
If connection.State = 0 Then GoTo ConnectionException '|
'----------------------------------------------------------------------------------------------------|
'Try to get the recordset based on the SQL query given as an input parameter. If any error ----------|
'occur, code moves to the SQLException label and throw an exception. '|
On Error GoTo SQLException '|
Set rs = connection.execute(sqlString) '|
On Error GoTo 0 '|
'----------------------------------------------------------------------------------------------------|
'Resize results array to have as many columns as fields in recordset [rs]. --------------------------|
columns = rs.fields.Count '|
'|
'For resizing array rows, constant REDIM_STEP is used. At this point it is not possible to quickly '|
'check how many records is stored in the recordset obtained above. '|
'Result array could be resized by one row for each record, but since array resizing is '|
'time-consuming operation this would impact performance of the function. This is why array is '|
'resized each time by more rows at the same time (defined in REDIM_STEP constant) and all the '|
'unused rows are removed at the end of the function. '|
ReDim results(1 To columns, 1 To REDIM_STEP) '|
'----------------------------------------------------------------------------------------------------|
'Assign column headers if [includeHeaders] parameters is set to True. -------------------------------|
If includeHeaders Then '|
row = 1 '|
'|
'--------------------------------------------------------------------------------------------| '|
For Each fld In rs.fields '| '|
column = column + 1 '| '|
results(column, 1) = fld.name '| '|
Next fld '| '|
'--------------------------------------------------------------------------------------------| '|
'|
End If '|
'----------------------------------------------------------------------------------------------------|
'Iterate through the recordset above earlier and put all the data into the result array. ------------|
Do Until rs.EOF '|
'|
row = row + 1 '|
'|
'Check if there is enough space in the result array for adding new entry. If not, -----------| '|
'add another set of rows. '| '|
If row > UBound(results, 2) Then '| '|
ReDim Preserve results(1 To columns, LBound(results, 2) To UBound(results, 2) + _
REDIM_STEP) '| '|
End If '| '|
'--------------------------------------------------------------------------------------------| '|
'|
'|
'Iterate through all the columns and put the values into the array. -------------------------| '|
For column = 1 To columns '| '|
'| '|
'Fields in recordset are indexed from 0, that is why we refer to [column - 1] index. '| '|
results(column, row) = rs.fields(column - 1).value '| '|
'| '|
Next column '| '|
'--------------------------------------------------------------------------------------------| '|
'|
'Move to the next record. '|
Call rs.MoveNext '|
'|
Loop '|
'----------------------------------------------------------------------------------------------------|
'Remove unused rows from the result array (or completely erase result array if no records have ------|
'been returned in the recordset). '|
If row Then '|
ReDim Preserve results(1 To columns, 1 To row) '|
Else '|
Erase results '|
End If '|
'----------------------------------------------------------------------------------------------------|
'Assign the result array to the function result.
getRecordsetAsArray = results
'==========================================================================================================
ExitPoint:
Set rs = eraseRecordset(rs)
Exit Function
'----------------------------------------------------------------------------------------------------------
ConnectionException:
'Error handler for the case if the input parameter [connection] is not of ADODB.Connection class or if
'this connection is closed.
GoTo ExitPoint
SQLException:
'Error handler for the case if the given SQL query cannot be completed for any reason.
GoTo ExitPoint
End Function