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 '********************************************************************** Option Explicit Private Const cstHEADER = "### PROPERTYVALUES ###" 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 ' Date BASIC variables give error. Change them to strings If VarType(pvValue) = vbDate Then oPropertyValue.Value = Utils._CStr(pvValue, False) Else oPropertyValue.Value = pvValue End If _MakePropertyValue() = oPropertyValue End Function ' _MakePropertyValue V1.3.0 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 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 = 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