path: root/wizards/source/access2base/Utils.xba

<?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>