REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CalledSub() As String
_CalledSub = Iif(_A2B_.CalledSub = "", "", _GetLabel("CALLTO") & " '" & _A2B_.CalledSub & "'")
End Function ' CalledSub V0.8.9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CheckArgument(pvItem As Variant _
, ByVal piArgNr As Integer _
, Byval pvType As Variant _
, ByVal Optional pvValid As Variant _
, ByVal Optional pvError As Boolean _
) As Variant
' Called by public functions to check the validity of their arguments
' pvItem Argument to be checked
' piArgNr Argument sequence number
' pvType Single value or array of allowed variable types
' If of string type must contain one or more valid pseudo-object types
' pvValid Single value or array of allowed values - comparison for strings is case-insensitive
' pvError If True (default), error handling in this routine. False in _setProperty methods in class modules.
_CheckArgument = False
Dim iVarType As Integer
If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType)
If iVarType = vbString Then ' pvType is a pseudo-type string
_CheckArgument = Utils._IsPseudo(pvItem, pvType)
Else
If IsMissing(pvValid) Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid)
End If
If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem)
vValue = poResultSet.getString(piColIndex) 'GIVE STRING A TRY
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
End Select
_getResultSetColumnValue = vValue
End Function ' getResultSetColumnValue V 0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _FinalProperty(psShortcut As String) As String
' Return the final property of a shortcut
Const cstEXCLAMATION = "!"
Const cstDOT = "."
Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
Dim sComponents() As String, sSubComponents() As String
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ImplementationName(pvObject As Variant) As String
' Use getImplementationName method or _getUNOTypeName function
Dim sObjectType As String
On Local Error Resume Next
sObjectType = pvObject.getImplementationName()
If sObjectType = "" Then sObjectType = _getUNOTypeName(pvObject)
_ImplementationName = sObjectType
End Function ' ImplementationName
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant
' Return True if pvItem is present in the pvList array (case insensitive comparison)
' Return the value in pvList if pvReturnValue = True
Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer
Dim iTop As Integer, iBottom As Integer, iFound As Integer
iItemVarType = VarType(pvItem)
If iItemVarType = vbNull Or IsNull(pvList) Then
_InList = False
ElseIf Not IsArray(pvList) Then
_InList = ( pvItem = pvList )
ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized
_InList = False
Else
bFound = False
_InList = False
iListVarType = VarType(pvList(LBound(pvList)))
If iListVarType = iItemVarType _
Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _
Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _
And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _
Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _
) Then
If IsMissing(pbBinarySearch) Then pbBinarySearch = False
If Not pbBinarySearch Then ' Linear search
For i = LBound(pvList) To UBound(pvList)
If iItemVarType = vbString Then bFound = ( pvList(i) <> "" And UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) )
If bFound Then
iFound = i
Exit For
End If
Next i
Else ' Binary search => array must be sorted
iTop = UBound(pvList)
iBottom = lBound(pvList)
Do
iFound = (iTop + iBottom) / 2
If ( iItemVarType = vbString And UCase(pvItem) > UCase(pvList(iFound)) ) Or ( iItemVarType <> vbString And pvItem > pvList(iFound) ) Then
iBottom = iFound + 1
Else
iTop = iFound - 1
End If
If iItemVarType = vbString Then bFound = ( pvList(i) <> "" And UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) )
Loop Until ( bFound ) Or ( iBottom > iTop )
End If
If bFound Then
If IsMissing(pvReturnValue) Then _InList = True Else _InList = pvList(iFound)
End If
End If
End If
Exit Function
End Function ' InList V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String
'Return type of property EVEN WHEN EMPTY ! (Used in date and time controls)
Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object
' On Local Error Resume Next
_InspectPropertyType = ""
Set oInspect1 = CreateUnoService("com.sun.star.script.Invocation")
Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection
If Not IsNull(oInspect2) Then
Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name
End If
Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing
End Function ' InspectPropertyType V1.0.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean
' Test pvObject: does it exist ?
' is the _Type item = one of the proposed pvTypes ?
' does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ?
Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant
If _ErrorHandler() Then On Local Error Goto Exit_False
_IsPseudo = False
bIsPseudo = False
vObject = pvObject ' To avoid "Object variable not set" error message
Select Case True
Case IsEmpty(vObject)
Case IsNull(vObject)
Case VarType(vObject) <> vbObject
Case Else
With vObject
Select Case True
Case IsEmpty(._Type)
Case IsNull(._Type)
Case ._Type = ""
Case Else
bIsPseudo = _InList(._Type, pvType)
If Not bIsPseudo Then ' If primary type did not succeed, give the subtype a chance
If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType)
End If
End Select
End With
End Select
If Not bIsPseudo Then Goto Exit_Function
Dim oDatabase As Variant, oForms As Variant
bPseudoExists = False
With vObject
Select Case ._Type
Case OBJFORM
If ._Name <> "" Then ' Check validity of form name
Set oDatabase = _CurrentDb
If oDatabase._Standalone Then
bPseudoExists = True
Else
Set oForms = oDatabase.Document.getFormDocuments()
bPseudoExists = ( oForms.HasByName(._Name) )
End If
End If
Case OBJDATABASE
If ._Standalone Then bPseudoExists = True Else bPseudoExists = .Document.CurrentController.IsConnected
Case OBJDIALOG
If ._Name <> "" Then ' Check validity of dialog name
Set oDatabase = _CurrentDb
bPseudoExists = ( oDatabase._hasDialog(._Name) )
End If
Case OBJCOLLECTION
bPseudoExists = True
Case OBJCONTROL
If Not IsNull(.ControlModel) And ._Name <> "" Then ' Check validity of control
Set oForms = .ControlModel.Parent
bPseudoExists = ( oForms.hasByName(._Name) )
End If
Case OBJSUBFORM
If Not IsNull(.DatabaseForm) And ._Name <> "" Then ' Check validity of subform
If .DatabaseForm.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then
Set oForms = .DatabaseForm.Parent
bPseudoExists = ( oForms.hasByName(._Name) )
End If
End If
Case OBJOPTIONGROUP
bPseudoExists = ( .Count > 0 )
Case OBJEVENT
bPseudoExists = ( Not IsNull(._EventSource) )
Case OBJPROPERTY
bPseudoExists = ( ._Name <> "" )
Case OBJTABLEDEF
bPseudoExists = ( ._Name <> "" And Not IsNull(.Table) )
Case OBJQUERYDEF
bPseudoExists = ( ._Name <> "" And Not IsNull(.Query) )
Case OBJRECORDSET
bPseudoExists = ( Not IsNull(.RowSet) )
Case OBJFIELD
bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) )
Case Else
End Select
End With
_IsPseudo = ( bIsPseudo And bPseudoExists )
Exit_Function:
Exit Function
Exit_False:
_IsPseudo = False
Goto Exit_Function
End Function ' IsPseudo V0.9.1
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _IsScalar(ByVal pvArg As Variant, Byval pvType As Variant, ByVal Optional pvValid As Variant) As Boolean
' Check type of pvArg and value in allowed pvValid list
_IsScalar = False
If IsArray(pvType) Then
If Not _InList(VarType(pvArg), pvType) Then Exit Function
ElseIf VarType(pvArg) <> pvType Then
If pvType = vbBoolean And VarType(pvArg) = vbLong Then
If pvArg < -1 And pvArg > 0 Then Exit Function ' Special boolean processing because the Not function returns a Long
Else
Exit Function
End If
End If
If Not IsMissing(pvValid) Then
If Not _InList(pvArg, pvValid) Then Exit Function
End If
_IsScalar = True
Exit_Function:
Exit Function
End Function ' IsScalar V0.7.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _PCase(ByVal psString As String) As String
' Return the proper case representation of argument
Dim vSubStrings() As Variant, i As Integer, iLen As Integer
vSubStrings = Split(psString, " ")
For i = 0 To UBound(vSubStrings)
iLen = Len(vSubStrings(i))
If iLen > 1 Then
vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) & LCase(Right(vSubStrings(i), iLen - 1))
ElseIf iLen = 1 Then
vSubStrings(i) = UCase(vSubStrings(i))
End If
Next i
_PCase = Join(vSubStrings, " ")
End Function ' PCase V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
' Returns psSql after substitution of [] by quote character
' [] square brackets in quoted strings not affected
Dim sQuote As String 'RDBMS specific quote character
Dim vSubStrings() As Variant, i As Integer
sQuote = CurrentDb.MetaData.IdentifierQuoteString
If sQuote = " " Then ' What's the string used to quote SQL identifiers? This returns a space " " if identifier quoting is not supported.
_QuoteString = psSql
Exit Function
End If
vSubStrings() = Split(psSql, sQuote)
For i = 0 To UBound(vSubStrings)
If (i Mod 2) = 0 Then ' Only even substrings are parsed for square brackets
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _ResetCalledSub(ByVal psSub As String) As String
' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
' Used to trace routine in/outs and to clarify error messages
If _A2B_.CalledSub = psSub Then _A2B_.CalledSub = ""
If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False)
End Sub ' ResetCalledSub
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _SetCalledSub(ByVal psSub As String) As String
' Called in top of each public function.
' Used to trace routine in/outs and to clarify error messages
If _A2B_.CalledSub = "" Then _A2B_.CalledSub = psSub
If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False)
End Sub ' SetCalledSub
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Surround(ByVal psName As String) As String
' Return [Name] if Name contains spaces
Const cstSquareOpen = "["
Const cstSquareClose = "]"
If InStr(psName, " ") > 0 Then
_Surround = cstSquareOpen & psName & cstSquareClose
Else
_Surround = psName
End If
End Function ' Surround
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Trim(ByVal psString As String) As String
' Remove leading and trailing spaces, remove surrounding square brackets
Const cstSquareOpen = "["
Const cstSquareClose = "]"
Dim sTrim As String
sTrim = Trim(psString)
_Trim = sTrim
If Len(sTrim) <= 2 Then Exit Function
If Left(sTrim, 1) = cstSquareOpen Then
If Right(sTrim, 1) = cstSquareClose Then
_Trim = Mid(sTrim, 2, Len(sTrim) - 2)
End If
End If
End Function ' Trim V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _TrimArray(pvArray As Variant) As Variant
' Remove empty strings from strings array
Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer
vTrim = Null
If Not IsArray(pvArray) Then
If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array()
ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty
vTrim = Array()
Else
iCount = 0
For i = LBound(pvArray) To UBound(pvArray)
If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1
Next i
If iCount = 0 Then
vTrim() = pvArray()
ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks
vTrim() = Array()
Else
ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount)
