Quelle  Utils.xba   Sprache: unbekannt

<?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="Utils" 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 =======================================================================================================================

Option Explicit

Global _A2B_   As Variant

REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS                               ---
REM -----------------------------------------------------------------------------------------------------------------------

Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant
'Add the item at the end of the array

Dim vArray() As Variant
 If IsArray(pvArray) Then vArray = pvArray Else vArray = Array()
 ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1)
 vArray(UBound(vArray)) = pvItem
 _AddArray() = vArray()

End Function

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant
'Return on top of argument the list of all numeric types
'Facilitates the entry of the list of allowed types in _CheckArgument calls

Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer
 If IsMissing(pvTypes) Then
  vNewList = Array()
 ElseIf IsArray(pvTypes) Then
  vNewList = pvTypes
 Else
  vNewList = Array(pvTypes)
 End If

 vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean)

 iSize = UBound(vNewlist)
 ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1)
 For i = 0 To UBound(vNumeric)
  vNewList(iSize + i + 1) = vNumeric(i)
 Next i

 _AddNumeric = vNewList

End Function  ' _AddNumeric V0.8.0

REM -----------------------------------------------------------------------------------------------------------------------

Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean

 _BitShift = False
 If piValue = 0 Then Exit Function
 Select Case piConstant
  Case 1
   Select Case piValue
    Case 1, 3, 5, 7, 9, 11, 13, 15:    _BitShift = True
    Case Else
   End Select
  Case 2
   Select Case piValue
    Case 2, 3, 6, 7, 10, 11, 14, 15:   _BitShift = True
    Case Else
   End Select
  Case 4
   Select Case piValue
    Case 4, 5, 6, 7, 12, 13, 14, 15:   _BitShift = True
    Case Else
   End Select
  Case 8
   Select Case piValue
    Case 8, 9, 10, 11, 12, 13, 14, 15:   _BitShift = True
    Case Else
   End Select
 End Select

End Function  ' BitShift

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, bValidIsMissing As Boolean
 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
  bValidIsMissing = ( VarType(pvValid) = vbError )
  If Not bValidIsMissing Then bValidIsMissing = IsMissing(pvValid)
  If bValidIsMissing 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)

Exit_Function:
 If Not _CheckArgument Then
  If IsMissing(pvError) Then pvError = True
  If pvError Then
   TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem))
  End If
 End If
 Exit Function
End Function ' CheckArgument V0.9.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
' pvArg may be a byte-array. Other arrays are processed recursively into a semicolon separated string

Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
Const cstLength = 50
Const cstByteLength = 25

 If IsMissing(pbShort) Then pbShort = True
 If IsArray(pvArg) Then
  sArg = ""
  If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then
   If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
   For i = 0 To iMax
    sArg = sArg & Right("00" & Hex(pvArg(i)), 2)
   Next i
  Else
   If pbShort Then
    sArg = "[ARRAY]"
   Else ' One-dimension arrays only
    For i = LBound(pvArg) To UBound(pvArg)
     sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call
    Next i
    If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1)
   End If
  End If
 Else
  Select Case VarType(pvArg)
   Case vbEmpty   :  sArg = "[EMPTY]"
   Case vbNull    :  sArg = "[NULL]"
   Case vbObject
    If IsNull(pvArg) Then
     sArg = "[NULL]"
    Else
     sObject = Utils._ImplementationName(pvArg)
     If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
        , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _
        , OBJDIALOG _
        )) Then
      Set oArg = pvArg  ' To avoid "Object variable not set" error message
      sArg = "[" & oArg._Type & "] " & oArg._Name
     ElseIf sObject <> "" Then
      sArg = "[" & sObject & "]"
     Else
      sArg = "[OBJECT]"
     End If
    End If
   Case vbVariant   :  sArg = "[VARIANT]"
   Case vbString
    ' Replace CR + LF by \n and HT by \t
    ' Replace semicolon by \; to allow semicolon separated rows
    sArg = Replace( _
       Replace( _
        Replace( _
         Replace( _
          Replace(pvArg, "\", "\\") _
         , Chr(13), "") _
        , Chr(10), "\n") _
       , Chr(9), "\t") _
      , ";", "\;")
   Case vbBoolean   :  sArg = Iif(pvArg, "[TRUE]", "[FALSE]")
   Case vbByte    :  sArg = Right("00" & Hex(pvArg), 2)
   Case vbSingle, vbDouble, vbCurrency
    sArg = Format(pvArg)
    If InStr(UCase(sArg), "E") = 0 Then sArg = Format(pvArg, "##0.0##")
    sArg = Replace(sArg, ",", ".")
   Case vbBigint   :  sArg = CStr(CLng(pvArg))
   Case vbDate    :  sArg = Year(pvArg) & "-" & Right("0" & Month(pvArg), 2) & "-" & Right("0" & Day(pvArg), 2) _
             & " " & Right("0" & Hour(pvArg), 2) & ":" & Right("0" & Minute(pvArg), 2) _
             & ":" & Right("0" & Second(pvArg), 2)
   Case Else    :  sArg = CStr(pvArg)
  End Select
 End If
 If pbShort And Len(sArg) > cstLength Then
  sLength = "(" & Len(sArg) & ")"
  sArg = Left(sArg, cstLength - 5 - Len(slength)) & " ... " & sLength
 End If
 _CStr = sArg

End Function ' CStr   V0.9.5

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant
' psArg is presumed an output of _CStr (stored in the meantime 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
 cstEscape1 = Chr(14)   ' Form feed used as temporary escape character for \\
 cstEscape2 = Chr(27)   ' ESC used as temporary escape character for \;

 _CVar = ""
 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( _
      Replace(psArg, "\\", cstEscape1) _
     , "\;", cstEscape2) _
    , "\n", Chr(10)) _
   , "\t", Chr(9))

 ' Semicolon separated string
 vArgs = Split(sArg, ";")
 If UBound(vArgs) > LBound(vArgs) Then  ' Process each item recursively
  vVars = Array()
  Redim vVars(LBound(vArgs) To UBound(vArgs))
  For i = LBound(vVars) To UBound(vVars)
   vVars(i) = _CVar(vArgs(i), pbStrDate)
  Next i
  _CVar = vVars
  Exit Function
 End If

 ' Usual case
 Select Case True
  Case sArg = "[EMPTY]"      : _CVar = EMPTY
  Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null
  Case sArg = "[OBJECT]"      : _CVar = Nothing
  Case sArg = "[TRUE]"      : _CVar = True
  Case sArg = "[FALSE]"      : _CVar = False
  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]+(e[-+]?[0-9]+)?$") <> ""
   _CVar = Val(sArg)     ' Scientific notation
  Case Else         : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";")
 End Select

End Function ' CVar   V1.7.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _DecimalPoint() As String
'Return locale decimal point
 _DecimalPoint = Mid(Format(0, "0.0"), 2, 1)
End Function

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _ExtensionLocation() As String
' Return the URL pointing to the location where OO installed the Access2Base extension
' Adapted from https://wiki.documentfoundation.org/Documentation/DevGuide/Extensions#Location_of_Installed_Extensions

Dim oPip As Object, sLocation As String
 Set oPip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider")
 _ExtensionLocation = oPip.getPackageLocation("Access2Base")

End Function ' ExtensionLocation

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetDialogLib() As Object
' Return actual Access2Base dialogs library

Dim oDialogLib As Object

 Set oDialogLib = DialogLibraries
 If oDialogLib.hasByName("Access2BaseDev") Then
  If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev")
  Set _GetDialogLib = DialogLibraries.Access2BaseDev
 ElseIf oDialogLib.hasByName("Access2Base") Then
  If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base")
  Set _GetDialogLib = DialogLibraries.Access2Base
 Else
  Set _GetDialogLib = Nothing
 EndIf

End Function

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetEventName(ByVal psProperty As String) As String
' Return the LO internal event name
' Corrects the typo on ErrorOccur(r?)ed

 _GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured")

End Function ' _GetEventName V1.7.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetEventScriptCode(poObject As Object _
     , ByVal psEvent As String _
     , ByVal psName As String _
     , Optional ByVal pbExtendName As Boolean _
     ) As String
' Extract from the parent of poObject the macro linked to psEvent.
' psName is the name of the object

Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String

 _GetEventScriptCode = ""
 If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function

 ' Find form index i.e. find control via getByIndex()
 If IsMissing(pbExtendName) Then pbExtendName = False
 Set oParent = poObject.getParent()
 iIndex = -1
 For i = 0 To oParent.getCount() - 1
  sName = oParent.getByIndex(i).Name
  If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
   iIndex = i
   Exit For
  End If
 Next i
 If iIndex < 0 Then Exit Function

 ' Find script event
 vEvents = oParent.getScriptEvents(iIndex)   ' Returns an array
 sEvent = Utils._GetEventName(psEvent)   ' Targeted event method
 For i = 0 To UBound(vEvents)
  If vEvents(i).EventMethod = sEvent Then
   _GetEventScriptCode = vEvents(i).ScriptCode
   Exit For
  End If
 Next i

End Function ' _GetEventScriptCode V1.7.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetResultSetColumnValue(poResultSet As Object _
           , ByVal piColIndex As Integer _
           , Optional ByVal pbReturnBinary As Boolean _
           ) As Variant
REM Modified from Roberto Benitez's BaseTools
REM get the data for the column specified by ColIndex
REM If pbReturnBinary = False (default) then return length of binary field
REM get type name from metadata

Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object
Dim bNullable As Boolean, lSize As Long
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535

 On Local Error Goto 0   ' Disable error handler
 vValue = Null     ' Default value if error
 If IsMissing(pbReturnBinary) Then pbReturnBinary = False
 With com.sun.star.sdbc.DataType
  iType = poResultSet.MetaData.getColumnType(piColIndex)
  bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
  Select Case iType
   Case .ARRAY      :  vValue = poResultSet.getArray(piColIndex)
   Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
             Set oValue = poResultSet.getBinaryStream(piColIndex)
             If bNullable Then
              If Not poResultSet.wasNull() Then
               If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
                lSize = cstMaxBinLength
               Else
                lSize = CLng(oValue.getLength())
               End If
               If lSize <= cstMaxBinLength And pbReturnBinary Then
                vValue = Array()
                oValue.readBytes(vValue, lSize)
               Else ' Return length of field, not content
                vValue = lSize
               End If
              End If
             End If
             oValue.closeInput()
   Case .BIT, .BOOLEAN    :  vValue = poResultSet.getBoolean(piColIndex)
   Case .DATE      :  vDateTime = poResultSet.getDate(piColIndex)
             If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
   Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
             vValue = Null
   Case .DOUBLE, .REAL    :  vValue = poResultSet.getDouble(piColIndex)
   Case .FLOAT      :  vValue = poResultSet.getFloat(piColIndex)
   Case .INTEGER, .SMALLINT  :  vValue = poResultSet.getInt(piColIndex)
   Case .BIGINT     :  vValue = poResultSet.getLong(piColIndex)
   Case .DECIMAL, .NUMERIC   :  vValue = poResultSet.getDouble(piColIndex)
   Case .SQLNULL     :  vValue = poResultSet.getNull(piColIndex)
   Case .OBJECT, .OTHER, .STRUCT :  vValue = Null
   Case .REF      :  vValue = poResultSet.getRef(piColIndex)
   Case .TINYINT     :  vValue = poResultSet.getShort(piColIndex)
   Case .CHAR, .VARCHAR   :  vValue = poResultSet.getString(piColIndex)
   Case .LONGVARCHAR, .CLOB
             Set oValue = poResultSet.getCharacterStream(piColIndex)
             If bNullable Then
              If Not poResultSet.wasNull() Then
               If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
                lSize = cstMaxTextLength
               Else
                lSize = CLng(oValue.getLength())
               End If
               oValue.closeInput()
               vValue = poResultSet.getString(piColIndex)
              End If
             Else
              oValue.closeInput()
             End If
   Case .TIME      :  vDateTime = poResultSet.getTime(piColIndex)
             If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
   Case .TIMESTAMP     :  vDateTime = poResultSet.getTimeStamp(piColIndex)
             If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
                + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
   Case Else
    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
  If bNullable Then
   If poResultSet.wasNull() Then vValue = Null
  End If
 End With

 _GetResultSetColumnValue = vValue

End Function ' GetResultSetColumnValue  V 1.5.0

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
 _FinalProperty = ""
 sComponents = Split(Trim(psShortcut), cstEXCLAMATION)
 If UBound(sComponents) = 0 Then Exit Function
 sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
 Select Case UBound(sSubComponents)
  Case 1
   _FinalProperty = sSubComponents(1)
  Case Else
   Exit Function
 End Select

End Function ' FinalProperty

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetProductName(ByVal Optional psFlag As String) as String
'Return OO product ("PRODUCT") and version numbers ("VERSION")
'Derived from Tools library

Dim oProdNameAccess as Object
Dim sVersion as String
Dim sProdName as String
 If IsMissing(psFlag) Then psFlag = "ALL"
 oProdNameAccess = _GetRegistryKeyContent("org.openoffice.Setup/Product")
 sProdName = oProdNameAccess.getByName("ooName")
 sVersion = oProdNameAccess.getByName("ooSetupVersionAboutBox")
 Select Case psFlag
  Case "ALL"   : _GetProductName = sProdName & " " & sVersion
  Case "PRODUCT"  : _GetProductName = sProdName
  Case "VERSION"  : _GetProductName = sVersion
 End Select
End Function ' GetProductName  V1.0.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetRandomFileName(ByVal psName As String) As String
' Return the full name of a random temporary file suffixed by psName

Dim sRandom As String
 sRandom = Right("000000" & Int(999999 * Rnd), 6)
 _GetRandomFileName = Utils._getTempDirectoryURL() & "/" & "A2B_TEMP_" & psName & "_" & sRandom

End Function ' GetRandomFileName

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant
'Implement ConfigurationProvider service
'Derived from Tools library

Dim oConfigProvider as Object
Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
 oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
 aNodePath(0).Name = "nodepath"
 aNodePath(0).Value = sKeyName
 If IsMissing(bForUpdate) Then bForUpdate = False
 If bForUpdate Then
  _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath())
 Else
  _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
 End If
End Function ' GetRegistryKeyContent V0.8.5

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _getTempDirectoryURL() As String
' Return the temporary directory defined in the OO Options (Paths)
Dim sDirectory As String, oSettings As Object, oPathSettings As Object

 If _ErrorHandler() Then On Local Error Goto Error_Function

 _getTempDirectoryURL = ""
 oPathSettings = createUnoService( "com.sun.star.util.PathSettings" )
 sDirectory = oPathSettings.GetPropertyValue( "Temp" )

 _getTempDirectoryURL = sDirectory

Exit_Function:
 Exit Function
Error_Function:
 TraceError("ERROR", Err, "_getTempDirectoryURL", Erl)
 _getTempDirectoryURL = ""
 Goto Exit_Function
End Function ' _getTempDirectoryURL  V0.8.5

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _getUNOTypeName(pvObject As Variant) As String
' Return the symbolic name of the pvObject (UNO-object) type
' Code-snippet from XRAY

Dim oService As Object, vClass as Variant
 _getUNOTypeName = ""
 On Local Error Resume Next
 oService = CreateUnoService("com.sun.star.reflection.CoreReflection")
 vClass = oService.getType(pvObject)
 If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT  Then
  _getUNOTypeName = vClass.Name
 End If
 oService.Dispose()

End Function ' getUNOTypeName

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean
' Return true if pvObject has the (UNO) method psMethod
' Code-snippet found in Bernard Marcelly's XRAY

Dim vInspect as Variant
 _hasUNOMethod = False
 If IsNull(pvObject) Then Exit Function
 On Local Error Resume Next
 vInspect = _A2B_.Introspection.Inspect(pvObject)
 _hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL)

End Function ' hasUNOMethod V0.8.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean
' Return true if pvObject has the (UNO) property psProperty
' Code-snippet found in Bernard Marcelly's XRAY

Dim vInspect as Variant
 _hasUNOProperty = False
 If IsNull(pvObject) Then Exit Function
 On Local Error Resume Next
 vInspect = _A2B_.Introspection.Inspect(pvObject)
 _hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)

End Function ' hasUNOProperty V0.8.0

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 IsMissing(pvReturnValue) Then pvReturnValue = False
 If iItemVarType = vbNull Or IsNull(pvList) Then
  _InList = False
 ElseIf Not IsArray(pvList) Then
  If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList )
  If Not pvReturnValue Then
   _InList = bFound
  Else
   If bFound Then _InList = pvList Else _InList = False
  End If
 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 = ( 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 = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) )
    Loop Until ( bFound ) Or ( iBottom > iTop )
   End If
   If bFound Then
    If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound)
   End If
  End If
 End If

 Exit Function

End Function ' InList V1.1.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 _IsLeft(psString As String, psLeft As String) As Boolean
' Return True if left part of psString = psLeft

Dim iLength As Integer
 iLength = Len(psLeft)
 _IsLeft = False
 If Len(psString) >= iLength Then
  If Left(psString, iLength) = psLeft Then _IsLeft = True
 End If

End Function

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _IsBinaryType(ByVal lType As Long) As Boolean

 With com.sun.star.sdbc.DataType
  Select Case lType
   Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
    _IsBinaryType = True
   Case Else
    _IsBinaryType = False
  End Select
 End With

End Function ' IsBinaryType V1.6.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 oDoc As Object, oForms As Variant
Const cstSeparator = "\;"

 bPseudoExists = False
 With vObject
  Select Case ._Type
   Case OBJFORM
    If ._Name <> "" Then  ' Check validity of form name
     Set oDoc = _A2B_.CurrentDocument()
     If oDoc.DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = _InList(._Name, Application._GetAllHierarchicalNames())
    End If
   Case OBJDATABASE
    If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection)
   Case OBJDIALOG
    If ._Name <> "" Then  ' Check validity of dialog name
     bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._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 OBJCOMMANDBAR
    bPseudoExists = ( Not IsNull(._Window) )
   Case OBJCOMMANDBARCONTROL
    bPseudoExists = ( Not IsNull(._ParentCommandBar) )
   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 OBJTEMPVAR
    If ._Name <> "" Then  ' Check validity of tempvar name
     bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) )
    End If
   Case Else
  End Select
 End With

 _IsPseudo = ( bIsPseudo And bPseudoExists )

Exit_Function:
 Exit Function
Exit_False:
 _IsPseudo = False
 Goto Exit_Function
End Function ' IsPseudo  V1.1.0

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 -----------------------------------------------------------------------------------------------------------------------
Private Function _PercentEncode(ByVal psChar As String) As String
' Percent encoding of single psChar character
' https://en.wikipedia.org/wiki/UTF-8

Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
 lChar = Asc(psChar)

 Select Case lChar
  Case 48 To 57, 65 To 90, 97 To 122  ' 0-9, A-Z, a-z
   _PercentEncode = psChar
  Case Asc("-"), Asc("."), Asc("_"), Asc("~")
   _PercentEncode = psChar
  Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings
   _PercentEncode = psChar
  Case Asc(" "), Asc("%")
   _PercentEncode = "%" & Right("00" & Hex(lChar), 2)
  Case 0 To 127
   _PercentEncode = psChar
  Case 128 To 2047
   sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2)
   sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
   _PercentEncode = sByte1 & sByte2
  Case 2048 To 65535
   sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2)
   sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
   sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
   _PercentEncode = sByte1 & sByte2 & sByte3
  Case Else    ' Not supported
   _PercentEncode = psChar
 End Select

 Exit Function

End Function ' _PercentEncode V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
' Loads all lines of a text file into a Variant array
' Any error reduces output to an empty array
' Input file name presumed in URL form

Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer
Const cstMaxLines = 16000  ' +/- the limit of array sizes in Basic
 On Local Error GoTo Error_Function
 vLines = Array()
 _ReadFileIntoArray = Array()
 If psFileName = "" Then Exit Function

 iFile = FreeFile()
 Open psFileName For Input Access Read Shared As #iFile
 iCount1 = 0
 Do While Not Eof(iFile) And iCount1 < cstMaxLines
  Line Input #iFile, sLine
  iCount1 = iCount1 + 1
 Loop
 Close #iFile

 ReDim vLines(0 To iCount1 - 1)  ' Reading file twice preferred to ReDim Preserve for performance reasons
 iFile = FreeFile()
 Open psFileName For Input Access Read Shared As #iFile
 iCount2 = 0
 Do While Not Eof(iFile) And iCount2 < iCount1
  Line Input #iFile, vLines(iCount2)
  iCount2 = iCount2 + 1
 Loop
 Close #iFile

Exit_Function:
 _ReadFileIntoArray() = vLines()
 Exit Function
Error_Function:
 vLines = Array()
 Resume Exit_Function
End Function ' _ReadFileIntoArray V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegexSearch(ByRef psString As String _
      , ByVal psRegex As String _
      , Optional ByRef plStart As Long _
      , Optional ByVal bForward As Boolean _
      ) 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
' To search again the same or another pattern => plStart = plStart + Len(matching string)

Dim oTextSearch As Object
Dim vOptions As Variant 'com.sun.star.util.SearchOptions
Dim lEnd As Long, vResult As Object

 _RegexSearch = ""
 Set oTextSearch = _A2B_.TextSearch  ' UNO XTextSearch service
 vOptions = _A2B_.SearchOptions
 vOptions.searchString = psRegex    ' Pattern to be searched
 oTextSearch.setOptions(vOptions)
 If IsMissing(plStart) Then plStart = 1
 If plStart <= 0 Or plStart > Len(psString) Then Exit Function
 If IsMissing(bForWard) Then bForward = True
 If bForward Then
  lEnd = Len(psString)
  vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
 Else
  lEnd = 1
  vResult = oTextSearch.searchForward(psString, plStart, lEnd - 1)
 End If
 With vResult
  If .subRegExpressions >= 1 Then
   ' http://www.openoffice.org/api/docs/common/ref/com/sun/star/util/SearchResult.html
   Select Case bForward
    Case True
     plStart = .startOffset(0) + 1
     lEnd = .endOffset(0) + 1
    Case False
     plStart = .endOffset(0) + 1
     lEnd = .startOffset(0)
   End Select
   _RegexSearch = Mid(psString, plStart, lEnd - plStart)
  Else
   plStart = 0
  End If
 End With

End Function

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegisterDialogEventScript(poObject As Object _
        , ByVal psEvent As String _
        , ByVal psListener As String _
        , ByVal psScriptCode As String _
        ) As Boolean
' Register a script event (psEvent) to poObject (Dialog or dialog Control)

Dim oEvents As Object, sEvent As String, sEventName As String, oEvent As Object

 _RegisterDialogEventScript = False
 If Not _hasUNOMethod(poObject, "getEvents") Then Exit Function

' Remove existing event, if any, then store new script code
 Set oEvents = poObject.getEvents()
 sEvent = Utils._GetEventName(psEvent)
 sEventName = "com.sun.star.awt." & psListener & "::" & sEvent
 If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName)
 Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
 With oEvent
  .ListenerType = psListener
  .EventMethod = sEvent
  .ScriptType = "Script"   ' Better than "Basic"
  .ScriptCode = psScriptCode
 End With
 oEvents.insertByName(sEventName, oEvent)

 _RegisterDialogEventScript = True

End Function ' _RegisterDialogEventScript V1.8.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegisterEventScript(poObject As Object _
        , ByVal psEvent As String _
        , ByVal psListener As String _
        , ByVal psScriptCode As String _
        , ByVal psName As String _
        , Optional ByVal pbExtendName As Boolean _
        ) As Boolean
' Register a script event (psEvent) to poObject (Form, SubForm or Control)

Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String

 _RegisterEventScript = False
 If Not _hasUNOMethod(poObject, "getParent") Then Exit Function

 ' Find object internal index i.e. how to reach it via getByIndex()
 If IsMissing(pbExtendName) Then pbExtendName = False
 Set oParent = poObject.getParent()
 iIndex = -1
 For i = 0 To oParent.getCount() - 1
  sName = oParent.getByIndex(i).Name
  If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
   iIndex = i
   Exit For
  End If
 Next i
 If iIndex < 0 Then Exit Function

 sEvent = Utils._GetEventName(psEvent)   ' Targeted event method
 If psScriptCode = "" Then
  oParent.revokeScriptEvent(iIndex, psListener, sEvent, "")
 Else
  Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
  With oEvent
   .ListenerType = psListener
   .EventMethod = sEvent
   .ScriptType = "Script"   ' Better than "Basic"
   .ScriptCode = psScriptCode
  End With
  oParent.registerScriptEvent(iIndex, oEvent)
 End If
 _RegisterEventScript = True

End Function ' _RegisterEventScript V1.7.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _ResetCalledSub(ByVal psSub 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 IsEmpty(_A2B_) Then Call Application._RootInit() ' Only when Utils module recompiled
  With _A2B_
   If .CalledSub = psSub Then .CalledSub = ""
   If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False)
  End With
End Sub   ' ResetCalledSub

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean
' Execute a given script with pvArgs() array of arguments

 On Local Error Goto Error_Function
 _RunScript = False
 If IsNull(ThisComponent) Then Goto Exit_Function

Dim oSCriptProvider As Object, oScript As Object, vResult As Variant

 Set oScriptProvider = ThisComponent.ScriptProvider()
 Set oScript = oScriptProvider.getScript(psScript)
 If IsMissing(pvArgs()) Then pvArgs() = Array()
 vResult = oScript.Invoke(pvArgs(), Array(), Array())
 _RunScript = True

Exit_Function:
 Exit Function
Error_Function:
 _RunScript = False
 Goto Exit_Function
End Function

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _SetCalledSub(ByVal psSub As String)
' Called in top of each public function.
' Used to trace routine in/outs and to clarify error messages
  If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
  With _A2B_
   If .CalledSub = "" Then
    .CalledSub = psSub
    .LastErrorCode = 0
    .LastErrorLevel = ""
    .ErrorText = ""
    .ErrorLongText = ""
   End If
   If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False)
  End With
End Sub   ' SetCalledSub

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Surround(ByVal psName As String) As String
' Return [Name] if Name contains spaces
' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots

Const cstSquareOpen = "["
Const cstSquareClose = "]"
Const cstDot = "."
Dim sName As String

 If InStr(psName, ".") > 0 Then
  sName = Join(Split(psName, cstDot), cstSquareClose & cstDot & cstSquareOpen)
  _Surround = cstSquareOpen & sName & cstSquareClose
 ElseIf 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, replace tabs by spaces
Const cstSquareOpen = "["
Const cstSquareClose = "]"
Dim sTrim As String

 sTrim = Trim(Replace(psString, vbTab, " "))
 _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)
   j = 0
   For i = LBound(pvArray) To UBound(pvArray)
    If Len(Trim(pvArray(i))) > 0 Then
     vTrim(j) = pvArray(i)
     j = j + 1
    End If
   Next i
  End If
 End If

 _TrimArray() = vTrim()

End Function ' TrimArray V0.9.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _
           , poResultSet As Object _
           , ByVal piColIndex As Integer _
           , ByVal pvValue As Variant _
           ) As Boolean
REM store the pvValue for the column specified by ColIndex
REM get type name from metadata

Dim iType As Integer, vDateTime As Variant, oValue As Object
Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535

 On Local Error Goto 0   ' Disable error handler
 _UpdateResultSetColumnValue = False
 With com.sun.star.sdbc.DataType
  iType = poResultSet.MetaData.getColumnType(piColIndex)
  iValueType = VarType(pvValue)
  sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex))
  bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )

  If bNullable And IsNull(pvValue) Then
   poResultSet.updateNull(piColIndex)
  Else
   Select Case iType
    Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT
              poResultSet.updateNull(piColIndex)
    Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
              poResultSet.updateBytes(piColIndex, pvValue)
    Case .BIT, .BOOLEAN    :  poResultSet.updateBoolean(piColIndex, pvValue)
    Case .DATE      :  vDateTime = CreateUnoStruct("com.sun.star.util.Date")
              vDateTime.Year = Year(pvValue)
              vDateTime.Month = Month(pvValue)
              vDateTime.Day = Day(pvValue)
              poResultSet.updateDate(piColIndex, vDateTime)
    Case .DECIMAL, .NUMERIC   :  poResultSet.updateDouble(piColIndex, pvValue)
    Case .DOUBLE, .REAL    :  poResultSet.updateDouble(piColIndex, pvValue)
    Case .FLOAT      :  poResultSet.updateFloat(piColIndex, pvValue)
    Case .INTEGER, .SMALLINT  :  poResultSet.updateInt(piColIndex, pvValue)
    Case .BIGINT     :  poResultSet.updateLong(piColIndex, pvValue)
    Case .DECIMAL, .NUMERIC   :  poResultSet.updateDouble(piColIndex, pvValue)
    Case .TINYINT     :  poResultSet.updateShort(piColIndex, pvValue)
    Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
              If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, "BINARY") > 0 Then  ' Sqlite exception ... !
               poResultSet.updateBytes(piColIndex, pvValue)
              Else
               poResultSet.updateString(piColIndex, pvValue)
              End If
    Case .TIME      :  vDateTime = CreateUnoStruct("com.sun.star.util.Time")
              vDateTime.Hours = Hour(pvValue)
              vDateTime.Minutes = Minute(pvValue)
              vDateTime.Seconds = Second(pvValue)
              'vDateTime.HundredthSeconds = 0
              poResultSet.updateTime(piColIndex, vDateTime)
    Case .TIMESTAMP     :  vDateTime = CreateUnoStruct("com.sun.star.util.DateTime")
              vDateTime.Year = Year(pvValue)
              vDateTime.Month = Month(pvValue)
              vDateTime.Day = Day(pvValue)
              vDateTime.Hours = Hour(pvValue)
              vDateTime.Minutes = Minute(pvValue)
              vDateTime.Seconds = Second(pvValue)
              'vDateTime.HundredthSeconds = 0
              poResultSet.updateTimestamp(piColIndex, vDateTime)
    Case Else
     If bNullable Then poResultSet.updateNull(piColIndex)
   End Select
  End If

 End With

 _UpdateResultSetColumnValue = True

End Function ' UpdateResultSetColumnValue  V 1.6.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _URLEncode(ByVal psToEncode As String) As String
' http://www.w3schools.com/tags/ref_urlencode.asp
' http://xkr.us/articles/javascript/encode-compare/
' http://tools.ietf.org/html/rfc3986

Dim sEncoded As String, sChar As String
Dim lCurrentChar As Long, bQuestionMark As Boolean

 sEncoded = ""
 bQuestionMark = False
 For lCurrentChar = 1 To Len(psToEncode)
  sChar = Mid(psToEncode, lCurrentChar, 1)
  Select Case sChar
   Case " ", "%"
    sEncoded = sEncoded & _PercentEncode(sChar)
   Case "?"     ' Is it the first "?" ?
    If bQuestionMark Then   ' "?" introduces in a URL the arguments part
     sEncoded = sEncoded & _PercentEncode(sChar)
    Else
     sEncoded = sEncoded & sChar
     bQuestionMark = True
    End If
   Case "\"
    If bQuestionMark Then
     sEncoded = sEncoded & _PercentEncode(sChar)
    Else
     sEncoded = sEncoded & "/" ' If Windows file naming ...
    End If
   Case Else
    If bQuestionMark Then
     sEncoded = sEncoded & _PercentEncode(sChar)
    Else
     sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL
    End If
  End Select
 Next lCurrentChar

 _URLEncode = sEncoded

End Function ' _URLEncode V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _UTF8Encode(ByVal psChar As String) As String
' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent
' http://www.w3schools.com/charsets/ref_html_utf8.asp

 Select Case psChar
  Case """"   : _UTF8Encode = "&quot;"
  Case "&"   : _UTF8Encode = "&amp;"
  Case "<"   : _UTF8Encode = "&lt;"
  Case ">"   : _UTF8Encode = "&gt;"
  Case "'"   : _UTF8Encode = "&apos;"
  Case ":", "/", "?", "#", "[", "]", "@"    ' Reserved characters
   _UTF8Encode = psChar
  Case Chr(13)  : _UTF8Encode = ""   ' Carriage return
  Case Chr(10)  : _UTF8Encode = "<br>"  ' Line Feed
  Case < Chr(126)  : _UTF8Encode = psChar
  Case "€"   : _UTF8Encode = "&euro;"
  Case Else   : _UTF8Encode = "&#" & Asc(psChar) & ";"
 End Select

 Exit Function

End Function ' _UTF8Encode V1.4.0

</script:module>