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
|
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="UtilProperty" script:language="StarBasic">
REM =======================================================================================================================
REM === The Access2Base library is a part of the LibreOffice project. ===
REM === Full documentation is available on http://www.access2base.com ===
REM =======================================================================================================================
'**********************************************************************
' UtilProperty module
'
' Module of utilities to manipulate arrays of PropertyValue's.
'**********************************************************************
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'**********************************************************************
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-02-25-01
' Jean-Pierre Ledure Adapted to Access2Base coding conventions
' PropValuesToStr rewritten and addition of StrToPropValues
' Bug corrected on date values
' Addition of support of 2-dimensional arrays
' Support of empty arrays to allow JSON conversions
'**********************************************************************
Option Explicit
Private Const cstHEADER = "### PROPERTYVALUES ###"
Private Const cstEMPTYARRAY = "### EMPTY ARRAY ###"
REM =======================================================================================================================
Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue
' Create and return a new com.sun.star.beans.PropertyValue.
Dim oPropertyValue As New com.sun.star.beans.PropertyValue
If Not IsMissing(psName) Then oPropertyValue.Name = psName
If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue)
_MakePropertyValue() = oPropertyValue
End Function ' _MakePropertyValue V1.3.0
REM =======================================================================================================================
Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant
' Date BASIC variables give error. Change them to strings
' Empty arrays should be replaced by cstEMPTYARRAY
If VarType(pvValue) = vbDate Then
_CheckPropertyValue = Utils._CStr(pvValue, False)
ElseIf IsArray(pvValue) Then
If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue
Else
_CheckPropertyValue = pvValue
End If
End Function ' _CheckPropertyValue
REM =======================================================================================================================
Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer
' Return the number of PropertyValue's in an array.
' Parameters:
' pvPropertyValuesArray - an array of PropertyValue's, that is an array of com.sun.star.beans.PropertyValue.
' Returns zero if the array contains no elements.
Dim iNumProperties As Integer
If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1
_NumPropertyValues() = iNumProperties
End Function ' _NumPropertyValues V1.3.0
REM =======================================================================================================================
Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer
' Find a particular named property from an array of PropertyValue's.
' Finds the index in the array of PropertyValue's and returns it, or returns -1 if it was not found.
Dim iNumProperties As Integer, i As Integer, vProp As Variant
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
For i = 0 To iNumProperties - 1
vProp = pvPropertyValuesArray(i)
If UCase(vProp.Name) = UCase(psPropName) Then
_FindPropertyIndex() = i
Exit Function
EndIf
Next i
_FindPropertyIndex() = -1
End Function ' _FindPropertyIndex V1.3.0
REM =======================================================================================================================
Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
' Find a particular named property from an array of PropertyValue's.
' Finds the PropertyValue and returns it, or returns Null if not found.
Dim iPropIndex As Integer, vProp As Variant
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
_FindProperty() = vProp
EndIf
End Function ' _FindProperty V1.3.0
REM =======================================================================================================================
Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant
' Get the value of a particular named property from an array of PropertyValue's.
' vDefaultValue - This value is returned if the property is not found in the array.
Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vValue = vProp.Value ' get the value from the PropertyValue
If VarType(vValue) = vbString Then
If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue
ElseIf IsArray(vValue) Then
If IsArray(vValue(0)) Then ' Array of arrays
vMatrix = Array()
ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0)))
For i = 0 To UBound(vValue)
For j = 0 To UBound(vValue(0))
vMatrix(i, j) = vValue(i)(j)
Next j
Next i
_GetPropertyValue() = vMatrix
Else
_GetPropertyValue() = vValue ' Simple vector OK
End If
Else
_GetPropertyValue() = vValue
End If
Else
If IsMissing(pvDefaultValue) Then pvDefaultValue = Null
_GetPropertyValue() = pvDefaultValue
EndIf
End Function ' _GetPropertyValue V1.3.0
REM =======================================================================================================================
Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant)
' Set the value of a particular named property from an array of PropertyValue's.
Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
' Found, the PropertyValue is already in the array. Just modify its value.
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vProp.Value = _CheckPropertyValue(pvValue) ' set the property value.
pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array
Else
' Not found, the array contains no PropertyValue with this name. Append new element to array.
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
If iNumProperties = 0 Then
pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue))
Else
' Make array larger.
Redim Preserve pvPropertyValuesArray(iNumProperties)
' Assign new PropertyValue
pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue)
EndIf
EndIf
End Sub ' _SetPropertyValue V1.3.0
REM =======================================================================================================================
Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String)
' Delete a particular named property from an array of PropertyValue's.
Dim iPropIndex As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)
End Sub ' _DeletePropertyValue V1.3.0
REM =======================================================================================================================
Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer)
' Delete a particular indexed property from an array of PropertyValue's.
Dim iNumProperties As Integer, i As Integer
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
' Did we find it?
If piPropIndex < 0 Then
' Do nothing
ElseIf iNumProperties = 1 Then
' Just return a new empty array
pvPropertyValuesArray = Array()
Else
' If it is NOT the last item in the array, then shift other elements down into it's position.
If piPropIndex < iNumProperties - 1 Then
' Bump items down lower in the array.
For i = piPropIndex To iNumProperties - 2
pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1)
Next i
EndIf
' Redimension the array to have one fewer element.
Redim Preserve pvPropertyValuesArray(iNumProperties - 2)
EndIf
End Sub ' _DeleteIndexedProperty V1.3.0
REM =======================================================================================================================
Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String
' Return a string with dumped content of the array of PropertyValue's.
' SYNTAX:
' NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...)
' NameOfArray = (10)
' 1;2;3;4;5;6;7;8;9;10
' NameOfMatrix = (2,10)
' 1;2;3;4;5;6;7;8;9;10
' A;B;C;D;E;F;G;H;I;J
' Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions)
Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant
Dim sName As String, vValue As Variant, iType As Integer
Dim cstLF As String
cstLF = vbLf()
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
sResult = cstHEADER & cstLF
For i = 0 To iNumProperties - 1
vProp = pvPropertyValuesArray(i)
sName = vProp.Name
vValue = vProp.Value
iType = VarType(vValue)
Select Case iType
Case < vbArray ' Scalar
sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF
Case Else ' Vector or matrix
If uBound(vValue, 1) < 0 Then
sResult = sResult & sName & " = (0)" & cstLF
' 1-dimension but vector of vectors must also be considered
ElseIf VarType(vValue(0)) >= vbArray Then
sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF
For j = 0 To UBound(vValue)
sResult = sResult & Utils._CStr(vValue(j), False) & cstLF
Next j
Else
sResult = sResult & sName & " = (" & UBound(vValue, 1) + 1 & ")" & cstLF
sResult = sResult & Utils._CStr(vValue, False) & cstLF
End If
End Select
Next i
_PropValuesToStr() = Left(sResult, Len(sResult) - 1) ' Remove last LF
End Function ' _PropValuesToStr V1.3.0
REM =======================================================================================================================
Public Function _StrToPropValues(psString) As Variant
' Return an array of PropertyValue's rebuilt from the string parameter
Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer
Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String
Dim lSearch As Long
Dim cstLF As String
Const cstEqualArray = " = (", cstEqual = " = "
cstLF = Chr(10)
_StrToPropValues = Array()
vResult = Array()
If psString = "" Then Exit Function
vString = Split(psString, cstLF)
If UBound(vString) <= 0 Then Exit Function ' There must be at least one name-value pair
If vString(0) <> cstHEADER Then Exit Function ' Check origin
iArray = -1
For i = 1 To UBound(vString)
If vString(i) <> "" Then ' Skip empty lines
If iArray < 0 Then ' Not busy with array row
lPosition = 1
sName = Utils._RegexSearch(vString(i), "^\b\w+\b", lPosition) ' Identifier
If sName = "" Then Exit Function
If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then ' Start array processing
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
sDim = Utils._RegexSearch(vString(i), "\([0-9]+\)", lSearch) ' e.g. (10)
If sDim = "(0)" Then ' Empty array
iRows = -1
vValue = Array()
_SetPropertyValue(vResult, sName, vValue)
ElseIf sDim <> "" Then ' Vector with content
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
iRows = 0
ReDim vValue(0 To iCols - 1)
iArray = 0
Else ' Matrix with content
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
sDim = Utils._RegexSearch(vString(i), "\([0-9]+,", lSearch) ' e.g. (10,
iRows = CInt(Mid(sDim, 2, Len(sDim) - 2))
sDim = Utils._RegexSearch(vString(i), ",[0-9]+\)", lSearch) ' e.g. ,20)
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
ReDim vValue(0 To iRows - 1)
iArray = 0
End If
ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then
vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1))
_SetPropertyValue(vResult, sName, vValue)
Else
Exit Function
End If
Else ' Line is an array row
If iRows = 0 Then
vValue = Utils._CVar(vString(i), True) ' Keep dates as strings
iArray = -1
_SetPropertyValue(vResult, sName, vValue)
Else
vValue(iArray) = Utils._CVar(vString(i), True)
If iArray < iRows - 1 Then
iArray = iArray + 1
Else
iArray = -1
_SetPropertyValue(vResult, sName, vValue)
End If
End If
End If
End If
Next i
_StrToPropValues = vResult
End Function
</script:module>
|
