summaryrefslogtreecommitdiffstats
path: root/wizards/source/access2base/Utils.xba
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 09:06:44 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 09:06:44 +0000
commited5640d8b587fbcfed7dd7967f3de04b37a76f26 (patch)
tree7a5f7c6c9d02226d7471cb3cc8fbbf631b415303 /wizards/source/access2base/Utils.xba
parentInitial commit. (diff)
downloadlibreoffice-ed5640d8b587fbcfed7dd7967f3de04b37a76f26.tar.xz
libreoffice-ed5640d8b587fbcfed7dd7967f3de04b37a76f26.zip
Adding upstream version 4:7.4.7.upstream/4%7.4.7upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'wizards/source/access2base/Utils.xba')
-rw-r--r--wizards/source/access2base/Utils.xba1308
1 files changed, 1308 insertions, 0 deletions
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
new file mode 100644
index 000000000..7242c605b
--- /dev/null
+++ b/wizards/source/access2base/Utils.xba
@@ -0,0 +1,1308 @@
+<?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
+&apos;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
+&apos;Return on top of argument the list of all numeric types
+&apos;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 &apos; _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 &apos; BitShift
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _CalledSub() As String
+ _CalledSub = Iif(_A2B_.CalledSub = &quot;&quot;, &quot;&quot;, _GetLabel(&quot;CALLTO&quot;) &amp; &quot; &apos;&quot; &amp; _A2B_.CalledSub &amp; &quot;&apos;&quot;)
+End Function &apos; 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
+&apos; Called by public functions to check the validity of their arguments
+&apos; pvItem Argument to be checked
+&apos; piArgNr Argument sequence number
+&apos; pvType Single value or array of allowed variable types
+&apos; If of string type must contain one or more valid pseudo-object types
+&apos; pvValid Single value or array of allowed values - comparison for strings is case-insensitive
+&apos; 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 &apos; 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 &apos; CheckArgument V0.9.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
+&apos; Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
+&apos; 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 = &quot;&quot;
+ If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then
+ If pbShort And UBound(pvArg) &gt; cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
+ For i = 0 To iMax
+ sArg = sArg &amp; Right(&quot;00&quot; &amp; Hex(pvArg(i)), 2)
+ Next i
+ Else
+ If pbShort Then
+ sArg = &quot;[ARRAY]&quot;
+ Else &apos; One-dimension arrays only
+ For i = LBound(pvArg) To UBound(pvArg)
+ sArg = sArg &amp; Utils._CStr(pvArg(i), pbShort) &amp; &quot;;&quot; &apos; Recursive call
+ Next i
+ If Len(sArg) &gt; 1 Then sArg = Left(sArg, Len(sArg) - 1)
+ End If
+ End If
+ Else
+ Select Case VarType(pvArg)
+ Case vbEmpty : sArg = &quot;[EMPTY]&quot;
+ Case vbNull : sArg = &quot;[NULL]&quot;
+ Case vbObject
+ If IsNull(pvArg) Then
+ sArg = &quot;[NULL]&quot;
+ 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 &apos; To avoid &quot;Object variable not set&quot; error message
+ sArg = &quot;[&quot; &amp; oArg._Type &amp; &quot;] &quot; &amp; oArg._Name
+ ElseIf sObject &lt;&gt; &quot;&quot; Then
+ sArg = &quot;[&quot; &amp; sObject &amp; &quot;]&quot;
+ Else
+ sArg = &quot;[OBJECT]&quot;
+ End If
+ End If
+ Case vbVariant : sArg = &quot;[VARIANT]&quot;
+ Case vbString
+ &apos; Replace CR + LF by \n and HT by \t
+ &apos; Replace semicolon by \; to allow semicolon separated rows
+ sArg = Replace( _
+ Replace( _
+ Replace( _
+ Replace( _
+ Replace(pvArg, &quot;\&quot;, &quot;\\&quot;) _
+ , Chr(13), &quot;&quot;) _
+ , Chr(10), &quot;\n&quot;) _
+ , Chr(9), &quot;\t&quot;) _
+ , &quot;;&quot;, &quot;\;&quot;)
+ Case vbBoolean : sArg = Iif(pvArg, &quot;[TRUE]&quot;, &quot;[FALSE]&quot;)
+ Case vbByte : sArg = Right(&quot;00&quot; &amp; Hex(pvArg), 2)
+ Case vbSingle, vbDouble, vbCurrency
+ sArg = Format(pvArg)
+ If InStr(UCase(sArg), &quot;E&quot;) = 0 Then sArg = Format(pvArg, &quot;##0.0##&quot;)
+ sArg = Replace(sArg, &quot;,&quot;, &quot;.&quot;)
+ Case vbBigint : sArg = CStr(CLng(pvArg))
+ Case vbDate : sArg = Year(pvArg) &amp; &quot;-&quot; &amp; Right(&quot;0&quot; &amp; Month(pvArg), 2) &amp; &quot;-&quot; &amp; Right(&quot;0&quot; &amp; Day(pvArg), 2) _
+ &amp; &quot; &quot; &amp; Right(&quot;0&quot; &amp; Hour(pvArg), 2) &amp; &quot;:&quot; &amp; Right(&quot;0&quot; &amp; Minute(pvArg), 2) _
+ &amp; &quot;:&quot; &amp; Right(&quot;0&quot; &amp; Second(pvArg), 2)
+ Case Else : sArg = CStr(pvArg)
+ End Select
+ End If
+ If pbShort And Len(sArg) &gt; cstLength Then
+ sLength = &quot;(&quot; &amp; Len(sArg) &amp; &quot;)&quot;
+ sArg = Left(sArg, cstLength - 5 - Len(slength)) &amp; &quot; ... &quot; &amp; sLength
+ End If
+ _CStr = sArg
+
+End Function &apos; CStr V0.9.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant
+&apos; psArg is presumed an output of _CStr (stored in the meantime in a text file f.i.)
+&apos; _CVar returns the corresponding original Variant variable or Null/Nothing if not possible
+&apos; Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
+&apos; pbStrDate = True keeps dates as strings
+
+Dim cstEscape1 As String, cstEscape2 As String
+ cstEscape1 = Chr(14) &apos; Form feed used as temporary escape character for \\
+ cstEscape2 = Chr(27) &apos; ESC used as temporary escape character for \;
+
+ _CVar = &quot;&quot;
+ 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, &quot;\\&quot;, cstEscape1) _
+ , &quot;\;&quot;, cstEscape2) _
+ , &quot;\n&quot;, Chr(10)) _
+ , &quot;\t&quot;, Chr(9))
+
+ &apos; Semicolon separated string
+ vArgs = Split(sArg, &quot;;&quot;)
+ If UBound(vArgs) &gt; LBound(vArgs) Then &apos; 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
+
+ &apos; Usual case
+ Select Case True
+ Case sArg = &quot;[EMPTY]&quot; : _CVar = EMPTY
+ Case sArg = &quot;[NULL]&quot; Or sArg = &quot;[VARIANT]&quot; : _CVar = Null
+ Case sArg = &quot;[OBJECT]&quot; : _CVar = Nothing
+ Case sArg = &quot;[TRUE]&quot; : _CVar = True
+ Case sArg = &quot;[FALSE]&quot; : _CVar = False
+ Case IsDate(sArg)
+ If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg)
+ Case IsNumeric(sArg)
+ If InStr(sArg, &quot;.&quot;) &gt; 0 Then
+ _CVar = Val(sArg)
+ Else
+ _CVar = CLng(Val(sArg)) &apos; Val always returns a double
+ End If
+ Case _RegexSearch(sArg, &quot;^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$&quot;) &lt;&gt; &quot;&quot;
+ _CVar = Val(sArg) &apos; Scientific notation
+ Case Else : _CVar = Replace(Replace(sArg, cstEscape1, &quot;\&quot;), cstEscape2, &quot;;&quot;)
+ End Select
+
+End Function &apos; CVar V1.7.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _DecimalPoint() As String
+&apos;Return locale decimal point
+ _DecimalPoint = Mid(Format(0, &quot;0.0&quot;), 2, 1)
+End Function
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _ExtensionLocation() As String
+&apos; Return the URL pointing to the location where OO installed the Access2Base extension
+&apos; Adapted from https://wiki.documentfoundation.org/Documentation/DevGuide/Extensions#Location_of_Installed_Extensions
+
+Dim oPip As Object, sLocation As String
+ Set oPip = GetDefaultContext.getByName(&quot;/singletons/com.sun.star.deployment.PackageInformationProvider&quot;)
+ _ExtensionLocation = oPip.getPackageLocation(&quot;Access2Base&quot;)
+
+End Function &apos; ExtensionLocation
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _GetDialogLib() As Object
+&apos; Return actual Access2Base dialogs library
+
+Dim oDialogLib As Object
+
+ Set oDialogLib = DialogLibraries
+ If oDialogLib.hasByName(&quot;Access2BaseDev&quot;) Then
+ If Not oDialogLib.IsLibraryLoaded(&quot;Access2BaseDev&quot;) Then oDialogLib.loadLibrary(&quot;Access2BaseDev&quot;)
+ Set _GetDialogLib = DialogLibraries.Access2BaseDev
+ ElseIf oDialogLib.hasByName(&quot;Access2Base&quot;) Then
+ If Not oDialogLib.IsLibraryLoaded(&quot;Access2Base&quot;) Then oDialogLib.loadLibrary(&quot;Access2Base&quot;)
+ Set _GetDialogLib = DialogLibraries.Access2Base
+ Else
+ Set _GetDialogLib = Nothing
+ EndIf
+
+End Function
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetEventName(ByVal psProperty As String) As String
+&apos; Return the LO internal event name
+&apos; Corrects the typo on ErrorOccur(r?)ed
+
+ _GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) &amp; Right(psProperty, Len(psProperty) - 3), &quot;errorOccurred&quot;, &quot;errorOccured&quot;)
+
+End Function &apos; _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
+&apos; Extract from the parent of poObject the macro linked to psEvent.
+&apos; 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 = &quot;&quot;
+ If Not Utils._hasUNOMethod(poObject, &quot;getParent&quot;) Then Exit Function
+
+ &apos; 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 = &quot;MainForm&quot; Or sName = &quot;Form&quot;)) Then
+ iIndex = i
+ Exit For
+ End If
+ Next i
+ If iIndex &lt; 0 Then Exit Function
+
+ &apos; Find script event
+ vEvents = oParent.getScriptEvents(iIndex) &apos; Returns an array
+ sEvent = Utils._GetEventName(psEvent) &apos; 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 &apos; _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&apos;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 &apos; Disable error handler
+ vValue = Null &apos; 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, &quot;getLength&quot;) Then &apos; When no recordset
+ lSize = cstMaxBinLength
+ Else
+ lSize = CLng(oValue.getLength())
+ End If
+ If lSize &lt;= cstMaxBinLength And pbReturnBinary Then
+ vValue = Array()
+ oValue.readBytes(vValue, lSize)
+ Else &apos; 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, &quot;getLength&quot;) Then &apos; 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)&apos;, 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)&apos;, vDateTime.HundredthSeconds)
+ Case Else
+ vValue = poResultSet.getString(piColIndex) &apos;GIVE STRING A TRY
+ If IsNumeric(vValue) Then vValue = Val(vValue) &apos;Required when type = &quot;&quot;, 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 &apos; GetResultSetColumnValue V 1.5.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _FinalProperty(psShortcut As String) As String
+&apos; Return the final property of a shortcut
+
+Const cstEXCLAMATION = &quot;!&quot;
+Const cstDOT = &quot;.&quot;
+
+Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
+Dim sComponents() As String, sSubComponents() As String
+ _FinalProperty = &quot;&quot;
+ 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 &apos; FinalProperty
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetProductName(ByVal Optional psFlag As String) as String
+&apos;Return OO product (&quot;PRODUCT&quot;) and version numbers (&quot;VERSION&quot;)
+&apos;Derived from Tools library
+
+Dim oProdNameAccess as Object
+Dim sVersion as String
+Dim sProdName as String
+ If IsMissing(psFlag) Then psFlag = &quot;ALL&quot;
+ oProdNameAccess = _GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
+ sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
+ sVersion = oProdNameAccess.getByName(&quot;ooSetupVersionAboutBox&quot;)
+ Select Case psFlag
+ Case &quot;ALL&quot; : _GetProductName = sProdName &amp; &quot; &quot; &amp; sVersion
+ Case &quot;PRODUCT&quot; : _GetProductName = sProdName
+ Case &quot;VERSION&quot; : _GetProductName = sVersion
+ End Select
+End Function &apos; GetProductName V1.0.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetRandomFileName(ByVal psName As String) As String
+&apos; Return the full name of a random temporary file suffixed by psName
+
+Dim sRandom As String
+ sRandom = Right(&quot;000000&quot; &amp; Int(999999 * Rnd), 6)
+ _GetRandomFileName = Utils._getTempDirectoryURL() &amp; &quot;/&quot; &amp; &quot;A2B_TEMP_&quot; &amp; psName &amp; &quot;_&quot; &amp; sRandom
+
+End Function &apos; GetRandomFileName
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant
+&apos;Implement ConfigurationProvider service
+&apos;Derived from Tools library
+
+Dim oConfigProvider as Object
+Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
+ oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
+ aNodePath(0).Name = &quot;nodepath&quot;
+ aNodePath(0).Value = sKeyName
+ If IsMissing(bForUpdate) Then bForUpdate = False
+ If bForUpdate Then
+ _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationUpdateAccess&quot;, aNodePath())
+ Else
+ _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
+ End If
+End Function &apos; GetRegistryKeyContent V0.8.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _getTempDirectoryURL() As String
+&apos; 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 = &quot;&quot;
+ oPathSettings = createUnoService( &quot;com.sun.star.util.PathSettings&quot; )
+ sDirectory = oPathSettings.GetPropertyValue( &quot;Temp&quot; )
+
+ _getTempDirectoryURL = sDirectory
+
+Exit_Function:
+ Exit Function
+Error_Function:
+ TraceError(&quot;ERROR&quot;, Err, &quot;_getTempDirectoryURL&quot;, Erl)
+ _getTempDirectoryURL = &quot;&quot;
+ Goto Exit_Function
+End Function &apos; _getTempDirectoryURL V0.8.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _getUNOTypeName(pvObject As Variant) As String
+&apos; Return the symbolic name of the pvObject (UNO-object) type
+&apos; Code-snippet from XRAY
+
+Dim oService As Object, vClass as Variant
+ _getUNOTypeName = &quot;&quot;
+ On Local Error Resume Next
+ oService = CreateUnoService(&quot;com.sun.star.reflection.CoreReflection&quot;)
+ vClass = oService.getType(pvObject)
+ If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then
+ _getUNOTypeName = vClass.Name
+ End If
+ oService.Dispose()
+
+End Function &apos; getUNOTypeName
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean
+&apos; Return true if pvObject has the (UNO) method psMethod
+&apos; Code-snippet found in Bernard Marcelly&apos;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 &apos; hasUNOMethod V0.8.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean
+&apos; Return true if pvObject has the (UNO) property psProperty
+&apos; Code-snippet found in Bernard Marcelly&apos;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 &apos; hasUNOProperty V0.8.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _ImplementationName(pvObject As Variant) As String
+&apos; Use getImplementationName method or _getUNOTypeName function
+
+Dim sObjectType As String
+ On Local Error Resume Next
+ sObjectType = pvObject.getImplementationName()
+ If sObjectType = &quot;&quot; Then sObjectType = _getUNOTypeName(pvObject)
+
+ _ImplementationName = sObjectType
+
+End Function &apos; ImplementationName
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant
+&apos; Return True if pvItem is present in the pvList array (case insensitive comparison)
+&apos; 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) &lt; LBound(pvList) Then &apos; 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 &apos; 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 &apos; Binary search =&gt; array must be sorted
+ iTop = UBound(pvList)
+ iBottom = lBound(pvList)
+ Do
+ iFound = (iTop + iBottom) / 2
+ If ( iItemVarType = vbString And UCase(pvItem) &gt; UCase(pvList(iFound)) ) Or ( iItemVarType &lt;&gt; vbString And pvItem &gt; 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 &gt; 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 &apos; InList V1.1.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String
+&apos;Return type of property EVEN WHEN EMPTY ! (Used in date and time controls)
+
+Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object
+&apos; On Local Error Resume Next
+ _InspectPropertyType = &quot;&quot;
+ Set oInspect1 = CreateUnoService(&quot;com.sun.star.script.Invocation&quot;)
+ 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 &apos; InspectPropertyType V1.0.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _IsLeft(psString As String, psLeft As String) As Boolean
+&apos; Return True if left part of psString = psLeft
+
+Dim iLength As Integer
+ iLength = Len(psLeft)
+ _IsLeft = False
+ If Len(psString) &gt;= 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 &apos; IsBinaryType V1.6.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean
+&apos; Test pvObject: does it exist ?
+&apos; is the _Type item = one of the proposed pvTypes ?
+&apos; 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 &apos; To avoid &quot;Object variable not set&quot; error message
+ Select Case True
+ Case IsEmpty(vObject)
+ Case IsNull(vObject)
+ Case VarType(vObject) &lt;&gt; vbObject
+ Case Else
+ With vObject
+ Select Case True
+ Case IsEmpty(._Type)
+ Case IsNull(._Type)
+ Case ._Type = &quot;&quot;
+ Case Else
+ bIsPseudo = _InList(._Type, pvType)
+ If Not bIsPseudo Then &apos; 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 = &quot;\;&quot;
+
+ bPseudoExists = False
+ With vObject
+ Select Case ._Type
+ Case OBJFORM
+ If ._Name &lt;&gt; &quot;&quot; Then &apos; 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 &lt;&gt; &quot;&quot; Then &apos; Check validity of dialog name
+ bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) )
+ End If
+ Case OBJCOLLECTION
+ bPseudoExists = True
+ Case OBJCONTROL
+ If Not IsNull(.ControlModel) And ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of control
+ Set oForms = .ControlModel.Parent
+ bPseudoExists = ( oForms.hasByName(._Name) )
+ End If
+ Case OBJSUBFORM
+ If Not IsNull(.DatabaseForm) And ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of subform
+ If .DatabaseForm.ImplementationName = &quot;com.sun.star.comp.forms.ODatabaseForm&quot; Then
+ Set oForms = .DatabaseForm.Parent
+ bPseudoExists = ( oForms.hasByName(._Name) )
+ End If
+ End If
+ Case OBJOPTIONGROUP
+ bPseudoExists = ( .Count &gt; 0 )
+ Case OBJCOMMANDBAR
+ bPseudoExists = ( Not IsNull(._Window) )
+ Case OBJCOMMANDBARCONTROL
+ bPseudoExists = ( Not IsNull(._ParentCommandBar) )
+ Case OBJEVENT
+ bPseudoExists = ( Not IsNull(._EventSource) )
+ Case OBJPROPERTY
+ bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; )
+ Case OBJTABLEDEF
+ bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Table) )
+ Case OBJQUERYDEF
+ bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Query) )
+ Case OBJRECORDSET
+ bPseudoExists = ( Not IsNull(.RowSet) )
+ Case OBJFIELD
+ bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Column) )
+ Case OBJTEMPVAR
+ If ._Name &lt;&gt; &quot;&quot; Then &apos; 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 &apos; IsPseudo V1.1.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _IsScalar(ByVal pvArg As Variant, ByVal pvType As Variant, ByVal Optional pvValid As Variant) As Boolean
+&apos; 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) &lt;&gt; pvType Then
+ If pvType = vbBoolean And VarType(pvArg) = vbLong Then
+ If pvArg &lt; -1 And pvArg &gt; 0 Then Exit Function &apos; 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 &apos; IsScalar V0.7.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _PCase(ByVal psString As String) As String
+&apos; Return the proper case representation of argument
+
+Dim vSubStrings() As Variant, i As Integer, iLen As Integer
+ vSubStrings = Split(psString, &quot; &quot;)
+ For i = 0 To UBound(vSubStrings)
+ iLen = Len(vSubStrings(i))
+ If iLen &gt; 1 Then
+ vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) &amp; LCase(Right(vSubStrings(i), iLen - 1))
+ ElseIf iLen = 1 Then
+ vSubStrings(i) = UCase(vSubStrings(i))
+ End If
+ Next i
+ _PCase = Join(vSubStrings, &quot; &quot;)
+
+End Function &apos; PCase V0.9.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PercentEncode(ByVal psChar As String) As String
+&apos; Percent encoding of single psChar character
+&apos; 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 &apos; 0-9, A-Z, a-z
+ _PercentEncode = psChar
+ Case Asc(&quot;-&quot;), Asc(&quot;.&quot;), Asc(&quot;_&quot;), Asc(&quot;~&quot;)
+ _PercentEncode = psChar
+ Case Asc(&quot;!&quot;), Asc(&quot;$&quot;), Asc(&quot;&amp;&quot;), Asc(&quot;&apos;&quot;), Asc(&quot;(&quot;), Asc(&quot;)&quot;), Asc(&quot;*&quot;), Asc(&quot;+&quot;), Asc(&quot;,&quot;), Asc(&quot;;&quot;), Asc(&quot;=&quot;) &apos; Reserved characters used as delimiters in query strings
+ _PercentEncode = psChar
+ Case Asc(&quot; &quot;), Asc(&quot;%&quot;)
+ _PercentEncode = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(lChar), 2)
+ Case 0 To 127
+ _PercentEncode = psChar
+ Case 128 To 2047
+ sByte1 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar / 64) + 192), 2)
+ sByte2 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex((lChar Mod 64) + 128), 2)
+ _PercentEncode = sByte1 &amp; sByte2
+ Case 2048 To 65535
+ sByte1 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar / 4096) + 224), 2)
+ sByte2 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
+ sByte3 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex((lChar Mod 64) + 128), 2)
+ _PercentEncode = sByte1 &amp; sByte2 &amp; sByte3
+ Case Else &apos; Not supported
+ _PercentEncode = psChar
+ End Select
+
+ Exit Function
+
+End Function &apos; _PercentEncode V1.4.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
+&apos; Loads all lines of a text file into a Variant array
+&apos; Any error reduces output to an empty array
+&apos; 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 &apos; +/- the limit of array sizes in Basic
+ On Local Error GoTo Error_Function
+ vLines = Array()
+ _ReadFileIntoArray = Array()
+ If psFileName = &quot;&quot; Then Exit Function
+
+ iFile = FreeFile()
+ Open psFileName For Input Access Read Shared As #iFile
+ iCount1 = 0
+ Do While Not Eof(iFile) And iCount1 &lt; cstMaxLines
+ Line Input #iFile, sLine
+ iCount1 = iCount1 + 1
+ Loop
+ Close #iFile
+
+ ReDim vLines(0 To iCount1 - 1) &apos; 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 &lt; 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 &apos; _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
+&apos; Search is not case-sensitive
+&apos; Return &quot;&quot; if regex not found, otherwise returns the matching string
+&apos; plStart = start position of psString to search (starts at 1)
+&apos; In output plStart contains the first position of the matching string
+&apos; To search again the same or another pattern =&gt; plStart = plStart + Len(matching string)
+
+Dim oTextSearch As Object
+Dim vOptions As Variant &apos;com.sun.star.util.SearchOptions
+Dim lEnd As Long, vResult As Object
+
+ _RegexSearch = &quot;&quot;
+ Set oTextSearch = _A2B_.TextSearch &apos; UNO XTextSearch service
+ vOptions = _A2B_.SearchOptions
+ vOptions.searchString = psRegex &apos; Pattern to be searched
+ oTextSearch.setOptions(vOptions)
+ If IsMissing(plStart) Then plStart = 1
+ If plStart &lt;= 0 Or plStart &gt; 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 &gt;= 1 Then
+ &apos; 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
+&apos; 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, &quot;getEvents&quot;) Then Exit Function
+
+&apos; Remove existing event, if any, then store new script code
+ Set oEvents = poObject.getEvents()
+ sEvent = Utils._GetEventName(psEvent)
+ sEventName = &quot;com.sun.star.awt.&quot; &amp; psListener &amp; &quot;::&quot; &amp; sEvent
+ If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName)
+ Set oEvent = CreateUnoStruct(&quot;com.sun.star.script.ScriptEventDescriptor&quot;)
+ With oEvent
+ .ListenerType = psListener
+ .EventMethod = sEvent
+ .ScriptType = &quot;Script&quot; &apos; Better than &quot;Basic&quot;
+ .ScriptCode = psScriptCode
+ End With
+ oEvents.insertByName(sEventName, oEvent)
+
+ _RegisterDialogEventScript = True
+
+End Function &apos; _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
+&apos; 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, &quot;getParent&quot;) Then Exit Function
+
+ &apos; 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 = &quot;MainForm&quot; Or sName = &quot;Form&quot;)) Then
+ iIndex = i
+ Exit For
+ End If
+ Next i
+ If iIndex &lt; 0 Then Exit Function
+
+ sEvent = Utils._GetEventName(psEvent) &apos; Targeted event method
+ If psScriptCode = &quot;&quot; Then
+ oParent.revokeScriptEvent(iIndex, psListener, sEvent, &quot;&quot;)
+ Else
+ Set oEvent = CreateUnoStruct(&quot;com.sun.star.script.ScriptEventDescriptor&quot;)
+ With oEvent
+ .ListenerType = psListener
+ .EventMethod = sEvent
+ .ScriptType = &quot;Script&quot; &apos; Better than &quot;Basic&quot;
+ .ScriptCode = psScriptCode
+ End With
+ oParent.registerScriptEvent(iIndex, oEvent)
+ End If
+ _RegisterEventScript = True
+
+End Function &apos; _RegisterEventScript V1.7.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Sub _ResetCalledSub(ByVal psSub As String)
+&apos; Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
+&apos; Used to trace routine in/outs and to clarify error messages
+ If IsEmpty(_A2B_) Then Call Application._RootInit() &apos; Only when Utils module recompiled
+ With _A2B_
+ If .CalledSub = psSub Then .CalledSub = &quot;&quot;
+ If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel(&quot;Exiting&quot;) &amp; &quot; &quot; &amp; psSub &amp; &quot; ...&quot;, False)
+ End With
+End Sub &apos; ResetCalledSub
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean
+&apos; 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)
+&apos; Called in top of each public function.
+&apos; Used to trace routine in/outs and to clarify error messages
+ If IsEmpty(_A2B_) Then Call Application._RootInit() &apos; First use of Access2Base in current LibO/AOO session
+ With _A2B_
+ If .CalledSub = &quot;&quot; Then
+ .CalledSub = psSub
+ .LastErrorCode = 0
+ .LastErrorLevel = &quot;&quot;
+ .ErrorText = &quot;&quot;
+ .ErrorLongText = &quot;&quot;
+ End If
+ If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel(&quot;Entering&quot;) &amp; &quot; &quot; &amp; psSub &amp; &quot; ...&quot;, False)
+ End With
+End Sub &apos; SetCalledSub
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _Surround(ByVal psName As String) As String
+&apos; Return [Name] if Name contains spaces
+&apos; Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots
+
+Const cstSquareOpen = &quot;[&quot;
+Const cstSquareClose = &quot;]&quot;
+Const cstDot = &quot;.&quot;
+Dim sName As String
+
+ If InStr(psName, &quot;.&quot;) &gt; 0 Then
+ sName = Join(Split(psName, cstDot), cstSquareClose &amp; cstDot &amp; cstSquareOpen)
+ _Surround = cstSquareOpen &amp; sName &amp; cstSquareClose
+ ElseIf InStr(psName, &quot; &quot;) &gt; 0 Then
+ _Surround = cstSquareOpen &amp; psName &amp; cstSquareClose
+ Else
+ _Surround = psName
+ End If
+
+End Function &apos; Surround
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _Trim(ByVal psString As String) As String
+&apos; Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces
+Const cstSquareOpen = &quot;[&quot;
+Const cstSquareClose = &quot;]&quot;
+Dim sTrim As String
+
+ sTrim = Trim(Replace(psString, vbTab, &quot; &quot;))
+ _Trim = sTrim
+ If Len(sTrim) &lt;= 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 &apos; Trim V0.9.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _TrimArray(pvArray As Variant) As Variant
+&apos; 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)) &gt; 0 Then vTrim = Array(pvArray) Else vTrim = Array()
+ ElseIf UBound(pvArray) &lt; LBound(pvArray) Then &apos; 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 &apos; 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))) &gt; 0 Then
+ vTrim(j) = pvArray(i)
+ j = j + 1
+ End If
+ Next i
+ End If
+ End If
+
+ _TrimArray() = vTrim()
+
+End Function &apos; 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 &apos; 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(&quot;com.sun.star.util.Date&quot;)
+ 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, &quot;BINARY&quot;) &gt; 0 Then &apos; Sqlite exception ... !
+ poResultSet.updateBytes(piColIndex, pvValue)
+ Else
+ poResultSet.updateString(piColIndex, pvValue)
+ End If
+ Case .TIME : vDateTime = CreateUnoStruct(&quot;com.sun.star.util.Time&quot;)
+ vDateTime.Hours = Hour(pvValue)
+ vDateTime.Minutes = Minute(pvValue)
+ vDateTime.Seconds = Second(pvValue)
+ &apos;vDateTime.HundredthSeconds = 0
+ poResultSet.updateTime(piColIndex, vDateTime)
+ Case .TIMESTAMP : vDateTime = CreateUnoStruct(&quot;com.sun.star.util.DateTime&quot;)
+ vDateTime.Year = Year(pvValue)
+ vDateTime.Month = Month(pvValue)
+ vDateTime.Day = Day(pvValue)
+ vDateTime.Hours = Hour(pvValue)
+ vDateTime.Minutes = Minute(pvValue)
+ vDateTime.Seconds = Second(pvValue)
+ &apos;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 &apos; UpdateResultSetColumnValue V 1.6.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _URLEncode(ByVal psToEncode As String) As String
+&apos; http://www.w3schools.com/tags/ref_urlencode.asp
+&apos; http://xkr.us/articles/javascript/encode-compare/
+&apos; http://tools.ietf.org/html/rfc3986
+
+Dim sEncoded As String, sChar As String
+Dim lCurrentChar As Long, bQuestionMark As Boolean
+
+ sEncoded = &quot;&quot;
+ bQuestionMark = False
+ For lCurrentChar = 1 To Len(psToEncode)
+ sChar = Mid(psToEncode, lCurrentChar, 1)
+ Select Case sChar
+ Case &quot; &quot;, &quot;%&quot;
+ sEncoded = sEncoded &amp; _PercentEncode(sChar)
+ Case &quot;?&quot; &apos; Is it the first &quot;?&quot; ?
+ If bQuestionMark Then &apos; &quot;?&quot; introduces in a URL the arguments part
+ sEncoded = sEncoded &amp; _PercentEncode(sChar)
+ Else
+ sEncoded = sEncoded &amp; sChar
+ bQuestionMark = True
+ End If
+ Case &quot;\&quot;
+ If bQuestionMark Then
+ sEncoded = sEncoded &amp; _PercentEncode(sChar)
+ Else
+ sEncoded = sEncoded &amp; &quot;/&quot; &apos; If Windows file naming ...
+ End If
+ Case Else
+ If bQuestionMark Then
+ sEncoded = sEncoded &amp; _PercentEncode(sChar)
+ Else
+ sEncoded = sEncoded &amp; _UTF8Encode(sChar) &apos; Because IE does not support %encoding in first part of URL
+ End If
+ End Select
+ Next lCurrentChar
+
+ _URLEncode = sEncoded
+
+End Function &apos; _URLEncode V1.4.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _UTF8Encode(ByVal psChar As String) As String
+&apos; &amp;-encoding of single psChar character (e.g. &quot;é&quot; becomes &quot;&amp;eacute;&quot; or numeric equivalent
+&apos; http://www.w3schools.com/charsets/ref_html_utf8.asp
+
+ Select Case psChar
+ Case &quot;&quot;&quot;&quot; : _UTF8Encode = &quot;&amp;quot;&quot;
+ Case &quot;&amp;&quot; : _UTF8Encode = &quot;&amp;amp;&quot;
+ Case &quot;&lt;&quot; : _UTF8Encode = &quot;&amp;lt;&quot;
+ Case &quot;&gt;&quot; : _UTF8Encode = &quot;&amp;gt;&quot;
+ Case &quot;&apos;&quot; : _UTF8Encode = &quot;&amp;apos;&quot;
+ Case &quot;:&quot;, &quot;/&quot;, &quot;?&quot;, &quot;#&quot;, &quot;[&quot;, &quot;]&quot;, &quot;@&quot; &apos; Reserved characters
+ _UTF8Encode = psChar
+ Case Chr(13) : _UTF8Encode = &quot;&quot; &apos; Carriage return
+ Case Chr(10) : _UTF8Encode = &quot;&lt;br&gt;&quot; &apos; Line Feed
+ Case &lt; Chr(126) : _UTF8Encode = psChar
+ Case &quot;€&quot; : _UTF8Encode = &quot;&amp;euro;&quot;
+ Case Else : _UTF8Encode = &quot;&amp;#&quot; &amp; Asc(psChar) &amp; &quot;;&quot;
+ End Select
+
+ Exit Function
+
+End Function &apos; _UTF8Encode V1.4.0
+
+</script:module> \ No newline at end of file