wizards/source/access2base/UtilProperty.xba

   1 <?xml version="1.0" encoding="UTF-8"?>
   2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
   3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="UtilProperty" script:language="StarBasic">
   4 REM =======================================================================================================================
   5 REM ===                                 The Access2Base library is a part of the LibreOffice project.                                                                   ===
   6 REM ===                                 Full documentation is available on http://www.access2base.com                                                                   ===
   7 REM =======================================================================================================================
   8
   9 &apos;**********************************************************************
  10 &apos;  UtilProperty module
  11 &apos;
  12 &apos;  Module of utilities to manipulate arrays of PropertyValue&apos;s.
  13 &apos;**********************************************************************
  14
  15 &apos;**********************************************************************
  16 &apos;  Copyright (c) 2003-2004 Danny Brewer
  17 &apos;  d29583@groovegarden.com
  18 &apos;**********************************************************************
  19
  20 &apos;**********************************************************************
  21 &apos;  If you make changes, please append to the change log below.
  22 &apos;
  23 &apos;  Change Log
  24 &apos;          Danny Brewer                    Revised 2004-02-25-01
  25 &apos;          Jean-Pierre Ledure              Adapted to Access2Base coding conventions
  26 &apos;                                                          PropValuesToStr rewritten and addition of StrToPropValues
  27 &apos;                                                          Bug corrected on date values
  28 &apos;                                                          Addition of support of 2-dimensional arrays
  29 &apos;                                                          Support of empty arrays to allow JSON conversions
  30 &apos;**********************************************************************
  31
  32 Option Explicit
  33
  34 Private Const cstHEADER = &quot;### PROPERTYVALUES ###&quot;
  35 Private Const cstEMPTYARRAY = &quot;### EMPTY ARRAY ###&quot;
  36
  37 REM =======================================================================================================================
  38 Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue
  39 &apos;   Create and return a new com.sun.star.beans.PropertyValue.
  40
  41 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
  42
  43         If Not IsMissing(psName) Then oPropertyValue.Name = psName
  44         If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue)
  45         _MakePropertyValue() = oPropertyValue
  46
  47 End Function    &apos;  _MakePropertyValue V1.3.0
  48
  49 REM =======================================================================================================================
  50 Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant
  51 &apos;  Date BASIC variables give error. Change them to strings
  52 &apos;  Empty arrays should be replaced by cstEMPTYARRAY
  53
  54         If VarType(pvValue) = vbDate Then
  55                 _CheckPropertyValue = Utils._CStr(pvValue, False)
  56         ElseIf IsArray(pvValue) Then
  57                 If UBound(pvValue, 1) &lt; LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue
  58         Else
  59                 _CheckPropertyValue = pvValue
  60         End If
  61
  62 End Function    &apos;  _CheckPropertyValue
  63
  64 REM =======================================================================================================================
  65 Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer
  66 &apos; Return the number of PropertyValue&apos;s in an array.
  67 &apos; Parameters:
  68 &apos;  pvPropertyValuesArray - an array of PropertyValue&apos;s, that is an array of com.sun.star.beans.PropertyValue.
  69 &apos; Returns zero if the array contains no elements.
  70
  71 Dim iNumProperties As Integer
  72         If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1
  73         _NumPropertyValues() = iNumProperties
  74
  75 End Function    &apos;  _NumPropertyValues V1.3.0
  76
  77 REM =======================================================================================================================
  78 Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer
  79 &apos; Find a particular named property from an array of PropertyValue&apos;s.
  80 &apos; Finds the index in the array of PropertyValue&apos;s and returns it, or returns -1 if it was not found.
  81
  82 Dim iNumProperties As Integer, i As Integer, vProp As Variant
  83         iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
  84         For i = 0 To iNumProperties - 1
  85                 vProp = pvPropertyValuesArray(i)
  86                 If UCase(vProp.Name) = UCase(psPropName) Then
  87                         _FindPropertyIndex() = i
  88                         Exit Function
  89                 EndIf
  90         Next i
  91         _FindPropertyIndex() = -1
  92
  93 End Function    &apos;  _FindPropertyIndex V1.3.0
  94
  95 REM =======================================================================================================================
  96 Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
  97 &apos; Find a particular named property from an array of PropertyValue&apos;s.
  98 &apos; Finds the PropertyValue and returns it, or returns Null if not found.
  99
 100 Dim iPropIndex As Integer, vProp As Variant
 101         iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
 102         If iPropIndex &gt;= 0 Then
 103                 vProp = pvPropertyValuesArray(iPropIndex) &apos; access array subscript
 104                 _FindProperty() = vProp
 105         EndIf
 106
 107 End Function    &apos;  _FindProperty V1.3.0
 108
 109 REM =======================================================================================================================
 110 Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant
 111 &apos; Get the value of a particular named property from an array of PropertyValue&apos;s.
 112 &apos; vDefaultValue      -   This value is returned if the property is not found in the array.
 113
 114 Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer
 115         iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
 116         If iPropIndex &gt;= 0 Then
 117                 vProp = pvPropertyValuesArray(iPropIndex)       &apos; access array subscript
 118                 vValue = vProp.Value                                            &apos; get the value from the PropertyValue
 119                 If VarType(vValue) = vbString Then
 120                         If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue
 121                 ElseIf IsArray(vValue) Then
 122                         If IsArray(vValue(0)) Then                              &apos; Array of arrays
 123                                 vMatrix = Array()
 124                                 ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0)))
 125                                 For i = 0 To UBound(vValue)
 126                                         For j = 0 To UBound(vValue(0))
 127                                                 vMatrix(i, j) = vValue(i)(j)
 128                                         Next j
 129                                 Next i
 130                                 _GetPropertyValue() = vMatrix
 131                         Else
 132                                 _GetPropertyValue() = vValue            &apos; Simple vector OK
 133                         End If
 134                 Else
 135                         _GetPropertyValue() = vValue
 136                 End If
 137         Else
 138                 If IsMissing(pvDefaultValue) Then pvDefaultValue = Null
 139                 _GetPropertyValue() = pvDefaultValue
 140         EndIf
 141
 142 End Function    &apos;  _GetPropertyValue V1.3.0
 143
 144 REM =======================================================================================================================
 145 Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant)
 146 &apos; Set the value of a particular named property from an array of PropertyValue&apos;s.
 147
 148 Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer
 149
 150         iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
 151         If iPropIndex &gt;= 0 Then
 152         &apos;  Found, the PropertyValue is already in the array. Just modify its value.
 153                 vProp = pvPropertyValuesArray(iPropIndex)       &apos; access array subscript
 154                 vProp.Value = _CheckPropertyValue(pvValue)      &apos; set the property value.
 155                 pvPropertyValuesArray(iPropIndex) = vProp       &apos; put it back into array
 156         Else
 157         &apos;  Not found, the array contains no PropertyValue with this name. Append new element to array.
 158                 iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
 159                 If iNumProperties = 0 Then
 160                         pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue))
 161                 Else
 162                 &apos;  Make array larger.
 163                         Redim Preserve pvPropertyValuesArray(iNumProperties)
 164                         &apos;  Assign new PropertyValue
 165                         pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue)
 166                 EndIf
 167         EndIf
 168
 169 End Sub         &apos;  _SetPropertyValue V1.3.0
 170
 171 REM =======================================================================================================================
 172 Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String)
 173 &apos; Delete a particular named property from an array of PropertyValue&apos;s.
 174
 175 Dim iPropIndex As Integer
 176         iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
 177         If iPropIndex &gt;= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)
 178
 179 End Sub         &apos;  _DeletePropertyValue V1.3.0
 180
 181 REM =======================================================================================================================
 182 Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer)
 183 &apos; Delete a particular indexed property from an array of PropertyValue&apos;s.
 184
 185 Dim iNumProperties As Integer, i As Integer
 186         iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
 187
 188         &apos; Did we find it?
 189         If piPropIndex &lt; 0 Then
 190                 &apos;  Do nothing
 191         ElseIf iNumProperties = 1 Then
 192                 &apos;  Just return a new empty array
 193                 pvPropertyValuesArray = Array()
 194         Else
 195                 &apos;  If it is NOT the last item in the array, then shift other elements down into it&apos;s position.
 196                 If piPropIndex &lt; iNumProperties - 1 Then
 197                         &apos;  Bump items down lower in the array.
 198                         For i = piPropIndex To iNumProperties - 2
 199                                 pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1)
 200                         Next i
 201                 EndIf
 202                 &apos;  Redimension the array to have one fewer element.
 203                 Redim Preserve pvPropertyValuesArray(iNumProperties - 2)
 204         EndIf
 205
 206 End Sub         &apos;  _DeleteIndexedProperty V1.3.0
 207
 208 REM =======================================================================================================================
 209 Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String
 210 &apos; Return a string with dumped content of the array of PropertyValue&apos;s.
 211 &apos;  SYNTAX:
 212 &apos;          NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...)
 213 &apos;          NameOfArray = (10)
 214 &apos;          1;2;3;4;5;6;7;8;9;10
 215 &apos;          NameOfMatrix = (2,10)
 216 &apos;          1;2;3;4;5;6;7;8;9;10
 217 &apos;          A;B;C;D;E;F;G;H;I;J
 218 &apos;  Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions)
 219
 220 Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant
 221 Dim sName As String, vValue As Variant, iType As Integer
 222 Dim cstLF As String
 223
 224         cstLF = vbLf()
 225         iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
 226
 227         sResult = cstHEADER &amp; cstLF
 228         For i = 0 To iNumProperties - 1
 229                 vProp = pvPropertyValuesArray(i)
 230                 sName = vProp.Name
 231                 vValue = vProp.Value
 232                 iType = VarType(vValue)
 233                 Select Case iType
 234                         Case &lt; vbArray                                       &apos;  Scalar
 235                                 sResult = sResult &amp; sName &amp; &quot; = &quot; &amp; Utils._CStr(vValue, False) &amp; cstLF
 236                         Case Else                                               &apos;  Vector or matrix
 237                                 If uBound(vValue, 1) &lt; 0 Then
 238                                         sResult = sResult &amp; sName &amp; &quot; = (0)&quot; &amp; cstLF
 239                                 &apos;  1-dimension but vector of vectors must also be considered
 240                                 ElseIf VarType(vValue(0)) &gt;= vbArray Then
 241                                         sResult = sResult &amp; sName &amp; &quot; = (&quot; &amp; UBound(vValue) + 1 &amp; &quot;,&quot; &amp; UBound(vValue(0)) + 1 &amp; &quot;)&quot; &amp; cstLF
 242                                         For j = 0 To UBound(vValue)
 243                                                 sResult = sResult &amp; Utils._CStr(vValue(j), False) &amp; cstLF
 244                                         Next j
 245                                 Else
 246                                         sResult = sResult &amp; sName &amp; &quot; = (&quot; &amp; UBound(vValue, 1) + 1 &amp; &quot;)&quot; &amp; cstLF
 247                                         sResult = sResult &amp; Utils._CStr(vValue, False) &amp; cstLF
 248                                 End If
 249                 End Select
 250         Next i
 251
 252         _PropValuesToStr() = Left(sResult, Len(sResult) - 1)    &apos;  Remove last LF
 253
 254 End Function    &apos;  _PropValuesToStr V1.3.0
 255
 256 REM =======================================================================================================================
 257 Public Function _StrToPropValues(psString) As Variant
 258 &apos; Return an array of PropertyValue&apos;s rebuilt from the string parameter
 259
 260 Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer
 261 Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String
 262 Dim lSearch As Long
 263 Dim cstLF As String
 264 Const cstEqualArray = &quot; = (&quot;, cstEqual = &quot; = &quot;
 265
 266         cstLF = Chr(10)
 267         _StrToPropValues = Array()
 268         vResult = Array()
 269
 270         If psString = &quot;&quot; Then Exit Function
 271         vString = Split(psString, cstLF)
 272         If UBound(vString) &lt;= 0 Then Exit Function           &apos;  There must be at least one name-value pair
 273         If vString(0) &lt;&gt; cstHEADER Then Exit Function     &apos;  Check origin
 274
 275         iArray = -1
 276         For i = 1 To UBound(vString)
 277                 If vString(i) &lt;&gt; &quot;&quot; Then                        &apos;  Skip empty lines
 278                         If iArray &lt; 0 Then                           &apos;  Not busy with array row
 279                                 lPosition = 1
 280                                 sName = Utils._RegexSearch(vString(i), &quot;^\b\w+\b&quot;, lPosition)         &apos;  Identifier
 281                                 If sName = &quot;&quot; Then Exit Function
 282                                 If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then       &apos;  Start array processing
 283                                         lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
 284                                         sDim = Utils._RegexSearch(vString(i), &quot;\([0-9]+\)&quot;, lSearch)  &apos;  e.g. (10)
 285                                         If sDim = &quot;(0)&quot; Then          &apos;  Empty array
 286                                                 iRows = -1
 287                                                 vValue = Array()
 288                                                 _SetPropertyValue(vResult, sName, vValue)
 289                                         ElseIf sDim &lt;&gt; &quot;&quot; Then          &apos;  Vector with content
 290                                                 iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
 291                                                 iRows = 0
 292                                                 ReDim vValue(0 To iCols - 1)
 293                                                 iArray = 0
 294                                         Else                                            &apos;  Matrix with content
 295                                                 lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
 296                                                 sDim = Utils._RegexSearch(vString(i), &quot;\([0-9]+,&quot;, lSearch)   &apos;  e.g. (10,
 297                                                 iRows = CInt(Mid(sDim, 2, Len(sDim) - 2))
 298                                                 sDim = Utils._RegexSearch(vString(i), &quot;,[0-9]+\)&quot;, lSearch)   &apos;  e.g. ,20)
 299                                                 iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
 300                                                 ReDim vValue(0 To iRows - 1)
 301                                                 iArray = 0
 302                                         End If
 303                                 ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then
 304                                         vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1))
 305                                         _SetPropertyValue(vResult, sName, vValue)
 306                                 Else
 307                                         Exit Function
 308                                 End If
 309                         Else                                                    &apos;  Line is an array row
 310                                 If iRows = 0 Then
 311                                         vValue = Utils._CVar(vString(i), True)          &apos;  Keep dates as strings
 312                                         iArray = -1
 313                                         _SetPropertyValue(vResult, sName, vValue)
 314                                 Else
 315                                         vValue(iArray) = Utils._CVar(vString(i), True)
 316                                         If iArray &lt; iRows - 1 Then
 317                                                 iArray = iArray + 1
 318                                         Else
 319                                                 iArray = -1
 320                                                 _SetPropertyValue(vResult, sName, vValue)
 321                                         End If
 322                                 End If
 323                         End If
 324                 End If
 325         Next i
 326
 327         _StrToPropValues = vResult
 328
 329 End Function
 330
 331 </script:module>