diff options
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/UtilProperty.xba | 331 |
1 files changed, 331 insertions, 0 deletions
diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba new file mode 100644 index 000000000..9f7ee4821 --- /dev/null +++ b/wizards/source/access2base/UtilProperty.xba @@ -0,0 +1,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>
\ No newline at end of file |