diff options
Diffstat (limited to 'wizards')
| -rw-r--r-- | wizards/source/access2base/Database.xba | 2 | ||||
| -rw-r--r-- | wizards/source/access2base/Recordset.xba | 5 | ||||
| -rw-r--r-- | wizards/source/access2base/UtilProperty.xba | 183 | ||||
| -rw-r--r-- | wizards/source/access2base/Utils.xba | 18 |
4 files changed, 172 insertions, 36 deletions
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba index 72445e0f3407..405eb65ae6c1 100644 --- a/wizards/source/access2base/Database.xba +++ b/wizards/source/access2base/Database.xba @@ -1322,6 +1322,8 @@ Const cstMaxRows = 200 If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol") If Not vFieldsBin(i) Then If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j) + If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull + If IsDate(vDataCell) And VarType(vDataCell) = vbString Then vDataCell = CDate(vDataCell) Select Case VarType(vDataCell) Case vbEmpty, vbNull vTdClass() = _AddArray(vTdClass, "null") diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba index 0f7be5b01827..81061bdad875 100644 --- a/wizards/source/access2base/Recordset.xba +++ b/wizards/source/access2base/Recordset.xba @@ -581,11 +581,13 @@ Const cstThisSub = "Recordset.getProperty" End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- -Public Function GetRows(ByVal Optional pvNumRows As variant) As Variant +Public Function GetRows(ByVal Optional pvNumRows As variant, ByVal Optional pbStrDate As Boolean) As Variant +' UNPUBLISHED - pbStrDate = True forces all dates to be converted into strings If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "Recordset.GetRows" Utils._SetCalledSub(cstThisSub) + If IsMissing(pbStrDate) Then pbStrDate = False Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer vMatrix() = Array() @@ -609,6 +611,7 @@ Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer lSize = lSize + 1 For i = 0 To iNumFields vMatrix(i, lSize) = _getResultSetColumnValue(RowSet, i + 1) + If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize)) Next i _Move("NEXT") Loop diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba index 6fbe1059e304..96e09552e948 100644 --- a/wizards/source/access2base/UtilProperty.xba +++ b/wizards/source/access2base/UtilProperty.xba @@ -22,24 +22,32 @@ REM ============================================================================ ' 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 Object - Set oPropertyValue = createUnoStruct( "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 = pvValue + 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(pvPropertyValuesArray As Variant) As Integer +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. @@ -52,7 +60,7 @@ Dim iNumProperties As Integer End Function ' _NumPropertyValues V1.3.0 REM ======================================================================================================================= -Public Function _FindPropertyIndex(pvPropertyValuesArray, ByVal psPropName As String ) As Integer +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. @@ -70,7 +78,7 @@ Dim iNumProperties As Integer, i As Integer, vProp As Variant End Function ' _FindPropertyIndex V1.3.0 REM ======================================================================================================================= -Public Function _FindProperty(pvPropertyValuesArray, ByVal psPropName As String) As com.sun.star.beans.PropertyValue +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. @@ -84,43 +92,59 @@ Dim iPropIndex As Integer, vProp As Variant End Function ' _FindProperty V1.3.0 REM ======================================================================================================================= -Function _GetPropertyValue(pvPropertyValuesArray, ByVal psPropName As String, Optional pvDefaultValue) As Variant +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 +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 - _GetPropertyValue() = vValue + 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 ======================================================================================================================= -Sub _SetPropertyValue(pvPropertyValuesArray, ByVal psPropName As String, ByVal pvValue) +Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue) ' 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) - ' Did we find it? If iPropIndex >= 0 Then - ' Found, the PropertyValue is already in the array. Just modify its value. + ' 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. + ' 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. + ' Make array larger. Redim Preserve pvPropertyValuesArray(iNumProperties) - ' Assign new PropertyValue + ' Assign new PropertyValue pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue) EndIf EndIf @@ -128,17 +152,17 @@ Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer End Sub ' _SetPropertyValue V1.3.0 REM ======================================================================================================================= -Sub _DeleteProperty(pvPropertyValuesArray, ByVal psPropName As String) +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) - _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex) + If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex) End Sub ' _DeletePropertyValue V1.3.0 REM ======================================================================================================================= -Public Sub _DeleteIndexedProperty(pvPropertyValuesArray, ByVal piPropIndex As Integer) +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 @@ -146,40 +170,139 @@ Dim iNumProperties As Integer, i As Integer ' Did we find it? If piPropIndex < 0 Then - ' Do nothing + ' Do nothing ElseIf iNumProperties = 1 Then - ' Just return a new empty array + ' 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 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. + ' 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. + ' Redimension the array to have one fewer element. Redim Preserve pvPropertyValuesArray(iNumProperties - 2) EndIf End Sub ' _DeleteIndexedProperty V1.3.0 REM ======================================================================================================================= -Public Function _PropValuesToStr(pvPropertyValuesArray) As String -' Convenience function to return a string which explains what PropertyValue's are in the array of PropertyValue's. +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, vVector As Variant +Dim cstLF As String -Dim iNumProperties As Integer, sResult As String, i As Integer, vProp As Variant -Dim sName As String, vValue As Variant + cstLF = Chr(10) iNumProperties = _NumPropertyValues(pvPropertyValuesArray) - sResult = Cstr(iNumProperties) & " Properties:" + sResult = cstHEADER & cstLF For i = 0 To iNumProperties - 1 vProp = pvPropertyValuesArray(i) sName = vProp.Name vValue = vProp.Value - sResult = sResult & Chr(13) & " " & sName & " = " & _CStr(vValue) + iType = VarType(vValue) + Select Case iType + Case < vbArray ' Scalar + sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF + Case Else ' Vector or matrix + ' 1-dimension but vector of vectors must also be considered + If VarType(vValue(0)) >= vbArray Then + sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF + vVector = Array() + ReDim vVector(0 To UBound(vValue(0))) + 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() = sResult + + _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 <> "" Then + iCols = CInt(Mid(sDim, 2, Len(sDim) - 2) + iRows = 0 + ReDim vValue(0 To iCols - 1) + Else + 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) + End If + iArray = 0 + 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 diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba index 583348b096a8..6028df496253 100644 --- a/wizards/source/access2base/Utils.xba +++ b/wizards/source/access2base/Utils.xba @@ -146,7 +146,7 @@ Const cstByteLength = 25 sArg = "[ARRAY]" Else ' One-dimension arrays only For i = LBound(pvArg) To UBound(pvArg) - sArg = sArg & Utils._CStr(pvArg(i)) & ";" ' Recursive call + sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call Next i If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1) End If @@ -205,10 +205,11 @@ Const cstByteLength = 25 End Function ' CStr V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _CVar(ByRef psArg As String) As Variant +Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant ' psArg is presumed an output of _CStr (stored in the mean time in a text file f.i.) ' _CVar returns the corresponding original variant variable or Null/Nothing if not possible ' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty +' pbStrDate = True keeps dates as strings Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\ @@ -218,6 +219,7 @@ Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant If Len(psArg) = 0 Then Exit Function Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer + If IsMissing(pbStrDate) Then pbStrDate = False sArg = Replace( _ Replace( _ Replace( _ @@ -232,7 +234,7 @@ Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer vVars = Array() Redim vVars(LBound(vArgs) To UBound(vArgs)) For i = LBound(vVars) To UBound(vVars) - vVars(i) = _CVar(vArgs(i)) + vVars(i) = _CVar(vArgs(i), pbStrDate) Next i _CVar = vVars Exit Function @@ -245,14 +247,15 @@ Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer Case sArg = "[OBJECT]" : _CVar = Nothing Case sArg = "[TRUE]" : _CVar = True Case sArg = "[FALSE]" : _CVar = False - Case IsDate(sArg) : _CVar = CDate(sArg) + Case IsDate(sArg) + If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg) Case IsNumeric(sArg) If InStr(sArg, ".") > 0 Then _CVar = Val(sArg) Else _CVar = CLng(Val(sArg)) ' Val always returns a double End If - Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$" <> "" + Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$") <> "" _CVar = Val(sArg) ' Scientific notation Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";") End Select @@ -914,6 +917,7 @@ Function _RegexSearch(ByRef psString As String _ , ByVal psRegex As String _ , Optional ByRef plStart As Long _ ) As String +' Search is not case-sensitive ' Return "" if regex not found, otherwise returns the matching string ' plStart = start position of psString to search (starts at 1) ' In output plStart contains the first position of the matching string @@ -929,9 +933,11 @@ Dim lEnd As Long .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP .searchFlag = 0 .searchString = psRegex ' Pattern to be searched + .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE End With oTextSearch.setOptions(vOptions) If IsMissing(plStart) Then plStart = 1 + If plStart <= 0 Then Exit Function lEnd = Len(psString) vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd) With vResult @@ -939,6 +945,8 @@ Dim lEnd As Long plStart = .startOffset(0) + 1 lEnd = .endOffset(0) + 1 _RegexSearch = Mid(psString, plStart, lEnd - plStart) + Else + plStart = 0 End If End With |