331 lines
15 KiB
Java
331 lines
15 KiB
Java
<?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> |