e568c9dca8
My Kate editor decided to do some whitespace cleanup, but maybe it's fine as the main changes are not targeting functional bits anyway. Change-Id: I5292e77e43055f94a6256a7f72d49fd59287d194 Reviewed-on: https://gerrit.libreoffice.org/c/core/+/132928 Tested-by: Ilmari Lauhakangas <ilmari.lauhakangas@libreoffice.org> Reviewed-by: Ilmari Lauhakangas <ilmari.lauhakangas@libreoffice.org>
1308 lines
No EOL
54 KiB
XML
1308 lines
No EOL
54 KiB
XML
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
|
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Utils" script:language="StarBasic">
|
|
REM =======================================================================================================================
|
|
REM === The Access2Base library is a part of the LibreOffice project. ===
|
|
REM === Full documentation is available on http://www.access2base.com ===
|
|
REM =======================================================================================================================
|
|
|
|
Option Explicit
|
|
|
|
Global _A2B_ As Variant
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- PRIVATE FUNCTIONS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant
|
|
'Add the item at the end of the array
|
|
|
|
Dim vArray() As Variant
|
|
If IsArray(pvArray) Then vArray = pvArray Else vArray = Array()
|
|
ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1)
|
|
vArray(UBound(vArray)) = pvItem
|
|
_AddArray() = vArray()
|
|
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant
|
|
'Return on top of argument the list of all numeric types
|
|
'Facilitates the entry of the list of allowed types in _CheckArgument calls
|
|
|
|
Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer
|
|
If IsMissing(pvTypes) Then
|
|
vNewList = Array()
|
|
ElseIf IsArray(pvTypes) Then
|
|
vNewList = pvTypes
|
|
Else
|
|
vNewList = Array(pvTypes)
|
|
End If
|
|
|
|
vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean)
|
|
|
|
iSize = UBound(vNewlist)
|
|
ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1)
|
|
For i = 0 To UBound(vNumeric)
|
|
vNewList(iSize + i + 1) = vNumeric(i)
|
|
Next i
|
|
|
|
_AddNumeric = vNewList
|
|
|
|
End Function ' _AddNumeric V0.8.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean
|
|
|
|
_BitShift = False
|
|
If piValue = 0 Then Exit Function
|
|
Select Case piConstant
|
|
Case 1
|
|
Select Case piValue
|
|
Case 1, 3, 5, 7, 9, 11, 13, 15: _BitShift = True
|
|
Case Else
|
|
End Select
|
|
Case 2
|
|
Select Case piValue
|
|
Case 2, 3, 6, 7, 10, 11, 14, 15: _BitShift = True
|
|
Case Else
|
|
End Select
|
|
Case 4
|
|
Select Case piValue
|
|
Case 4, 5, 6, 7, 12, 13, 14, 15: _BitShift = True
|
|
Case Else
|
|
End Select
|
|
Case 8
|
|
Select Case piValue
|
|
Case 8, 9, 10, 11, 12, 13, 14, 15: _BitShift = True
|
|
Case Else
|
|
End Select
|
|
End Select
|
|
|
|
End Function ' BitShift
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _CalledSub() As String
|
|
_CalledSub = Iif(_A2B_.CalledSub = "", "", _GetLabel("CALLTO") & " '" & _A2B_.CalledSub & "'")
|
|
End Function ' CalledSub V0.8.9
|
|
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _CheckArgument(pvItem As Variant _
|
|
, ByVal piArgNr As Integer _
|
|
, ByVal pvType As Variant _
|
|
, ByVal Optional pvValid As Variant _
|
|
, ByVal Optional pvError As Boolean _
|
|
) As Variant
|
|
' Called by public functions to check the validity of their arguments
|
|
' pvItem Argument to be checked
|
|
' piArgNr Argument sequence number
|
|
' pvType Single value or array of allowed variable types
|
|
' If of string type must contain one or more valid pseudo-object types
|
|
' pvValid Single value or array of allowed values - comparison for strings is case-insensitive
|
|
' pvError If True (default), error handling in this routine. False in _setProperty methods in class modules.
|
|
|
|
_CheckArgument = False
|
|
|
|
Dim iVarType As Integer, bValidIsMissing As Boolean
|
|
If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType)
|
|
If iVarType = vbString Then ' pvType is a pseudo-type string
|
|
_CheckArgument = Utils._IsPseudo(pvItem, pvType)
|
|
Else
|
|
bValidIsMissing = ( VarType(pvValid) = vbError )
|
|
If Not bValidIsMissing Then bValidIsMissing = IsMissing(pvValid)
|
|
If bValidIsMissing Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid)
|
|
End If
|
|
|
|
If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem)
|
|
|
|
Exit_Function:
|
|
If Not _CheckArgument Then
|
|
If IsMissing(pvError) Then pvError = True
|
|
If pvError Then
|
|
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem))
|
|
End If
|
|
End If
|
|
Exit Function
|
|
End Function ' CheckArgument V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
|
|
' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
|
|
' pvArg may be a byte-array. Other arrays are processed recursively into a semicolon separated string
|
|
|
|
Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
|
|
Const cstLength = 50
|
|
Const cstByteLength = 25
|
|
|
|
If IsMissing(pbShort) Then pbShort = True
|
|
If IsArray(pvArg) Then
|
|
sArg = ""
|
|
If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then
|
|
If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
|
|
For i = 0 To iMax
|
|
sArg = sArg & Right("00" & Hex(pvArg(i)), 2)
|
|
Next i
|
|
Else
|
|
If pbShort Then
|
|
sArg = "[ARRAY]"
|
|
Else ' One-dimension arrays only
|
|
For i = LBound(pvArg) To UBound(pvArg)
|
|
sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call
|
|
Next i
|
|
If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1)
|
|
End If
|
|
End If
|
|
Else
|
|
Select Case VarType(pvArg)
|
|
Case vbEmpty : sArg = "[EMPTY]"
|
|
Case vbNull : sArg = "[NULL]"
|
|
Case vbObject
|
|
If IsNull(pvArg) Then
|
|
sArg = "[NULL]"
|
|
Else
|
|
sObject = Utils._ImplementationName(pvArg)
|
|
If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
|
|
, OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _
|
|
, OBJDIALOG _
|
|
)) Then
|
|
Set oArg = pvArg ' To avoid "Object variable not set" error message
|
|
sArg = "[" & oArg._Type & "] " & oArg._Name
|
|
ElseIf sObject <> "" Then
|
|
sArg = "[" & sObject & "]"
|
|
Else
|
|
sArg = "[OBJECT]"
|
|
End If
|
|
End If
|
|
Case vbVariant : sArg = "[VARIANT]"
|
|
Case vbString
|
|
' Replace CR + LF by \n and HT by \t
|
|
' Replace semicolon by \; to allow semicolon separated rows
|
|
sArg = Replace( _
|
|
Replace( _
|
|
Replace( _
|
|
Replace( _
|
|
Replace(pvArg, "\", "\\") _
|
|
, Chr(13), "") _
|
|
, Chr(10), "\n") _
|
|
, Chr(9), "\t") _
|
|
, ";", "\;")
|
|
Case vbBoolean : sArg = Iif(pvArg, "[TRUE]", "[FALSE]")
|
|
Case vbByte : sArg = Right("00" & Hex(pvArg), 2)
|
|
Case vbSingle, vbDouble, vbCurrency
|
|
sArg = Format(pvArg)
|
|
If InStr(UCase(sArg), "E") = 0 Then sArg = Format(pvArg, "##0.0##")
|
|
sArg = Replace(sArg, ",", ".")
|
|
Case vbBigint : sArg = CStr(CLng(pvArg))
|
|
Case vbDate : sArg = Year(pvArg) & "-" & Right("0" & Month(pvArg), 2) & "-" & Right("0" & Day(pvArg), 2) _
|
|
& " " & Right("0" & Hour(pvArg), 2) & ":" & Right("0" & Minute(pvArg), 2) _
|
|
& ":" & Right("0" & Second(pvArg), 2)
|
|
Case Else : sArg = CStr(pvArg)
|
|
End Select
|
|
End If
|
|
If pbShort And Len(sArg) > cstLength Then
|
|
sLength = "(" & Len(sArg) & ")"
|
|
sArg = Left(sArg, cstLength - 5 - Len(slength)) & " ... " & sLength
|
|
End If
|
|
_CStr = sArg
|
|
|
|
End Function ' CStr V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant
|
|
' psArg is presumed an output of _CStr (stored in the meantime in a text file f.i.)
|
|
' _CVar returns the corresponding original Variant variable or Null/Nothing if not possible
|
|
' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
|
|
' pbStrDate = True keeps dates as strings
|
|
|
|
Dim cstEscape1 As String, cstEscape2 As String
|
|
cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\
|
|
cstEscape2 = Chr(27) ' ESC used as temporary escape character for \;
|
|
|
|
_CVar = ""
|
|
If Len(psArg) = 0 Then Exit Function
|
|
|
|
Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
|
|
If IsMissing(pbStrDate) Then pbStrDate = False
|
|
sArg = Replace( _
|
|
Replace( _
|
|
Replace( _
|
|
Replace(psArg, "\\", cstEscape1) _
|
|
, "\;", cstEscape2) _
|
|
, "\n", Chr(10)) _
|
|
, "\t", Chr(9))
|
|
|
|
' Semicolon separated string
|
|
vArgs = Split(sArg, ";")
|
|
If UBound(vArgs) > LBound(vArgs) Then ' Process each item recursively
|
|
vVars = Array()
|
|
Redim vVars(LBound(vArgs) To UBound(vArgs))
|
|
For i = LBound(vVars) To UBound(vVars)
|
|
vVars(i) = _CVar(vArgs(i), pbStrDate)
|
|
Next i
|
|
_CVar = vVars
|
|
Exit Function
|
|
End If
|
|
|
|
' Usual case
|
|
Select Case True
|
|
Case sArg = "[EMPTY]" : _CVar = EMPTY
|
|
Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null
|
|
Case sArg = "[OBJECT]" : _CVar = Nothing
|
|
Case sArg = "[TRUE]" : _CVar = True
|
|
Case sArg = "[FALSE]" : _CVar = False
|
|
Case IsDate(sArg)
|
|
If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg)
|
|
Case IsNumeric(sArg)
|
|
If InStr(sArg, ".") > 0 Then
|
|
_CVar = Val(sArg)
|
|
Else
|
|
_CVar = CLng(Val(sArg)) ' Val always returns a double
|
|
End If
|
|
Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$") <> ""
|
|
_CVar = Val(sArg) ' Scientific notation
|
|
Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";")
|
|
End Select
|
|
|
|
End Function ' CVar V1.7.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _DecimalPoint() As String
|
|
'Return locale decimal point
|
|
_DecimalPoint = Mid(Format(0, "0.0"), 2, 1)
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _ExtensionLocation() As String
|
|
' Return the URL pointing to the location where OO installed the Access2Base extension
|
|
' Adapted from https://wiki.documentfoundation.org/Documentation/DevGuide/Extensions#Location_of_Installed_Extensions
|
|
|
|
Dim oPip As Object, sLocation As String
|
|
Set oPip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider")
|
|
_ExtensionLocation = oPip.getPackageLocation("Access2Base")
|
|
|
|
End Function ' ExtensionLocation
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _GetDialogLib() As Object
|
|
' Return actual Access2Base dialogs library
|
|
|
|
Dim oDialogLib As Object
|
|
|
|
Set oDialogLib = DialogLibraries
|
|
If oDialogLib.hasByName("Access2BaseDev") Then
|
|
If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev")
|
|
Set _GetDialogLib = DialogLibraries.Access2BaseDev
|
|
ElseIf oDialogLib.hasByName("Access2Base") Then
|
|
If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base")
|
|
Set _GetDialogLib = DialogLibraries.Access2Base
|
|
Else
|
|
Set _GetDialogLib = Nothing
|
|
EndIf
|
|
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _GetEventName(ByVal psProperty As String) As String
|
|
' Return the LO internal event name
|
|
' Corrects the typo on ErrorOccur(r?)ed
|
|
|
|
_GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured")
|
|
|
|
End Function ' _GetEventName V1.7.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _GetEventScriptCode(poObject As Object _
|
|
, ByVal psEvent As String _
|
|
, ByVal psName As String _
|
|
, Optional ByVal pbExtendName As Boolean _
|
|
) As String
|
|
' Extract from the parent of poObject the macro linked to psEvent.
|
|
' psName is the name of the object
|
|
|
|
Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String
|
|
|
|
_GetEventScriptCode = ""
|
|
If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function
|
|
|
|
' Find form index i.e. find control via getByIndex()
|
|
If IsMissing(pbExtendName) Then pbExtendName = False
|
|
Set oParent = poObject.getParent()
|
|
iIndex = -1
|
|
For i = 0 To oParent.getCount() - 1
|
|
sName = oParent.getByIndex(i).Name
|
|
If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
|
|
iIndex = i
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If iIndex < 0 Then Exit Function
|
|
|
|
' Find script event
|
|
vEvents = oParent.getScriptEvents(iIndex) ' Returns an array
|
|
sEvent = Utils._GetEventName(psEvent) ' Targeted event method
|
|
For i = 0 To UBound(vEvents)
|
|
If vEvents(i).EventMethod = sEvent Then
|
|
_GetEventScriptCode = vEvents(i).ScriptCode
|
|
Exit For
|
|
End If
|
|
Next i
|
|
|
|
End Function ' _GetEventScriptCode V1.7.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _GetResultSetColumnValue(poResultSet As Object _
|
|
, ByVal piColIndex As Integer _
|
|
, Optional ByVal pbReturnBinary As Boolean _
|
|
) As Variant
|
|
REM Modified from Roberto Benitez's BaseTools
|
|
REM get the data for the column specified by ColIndex
|
|
REM If pbReturnBinary = False (default) then return length of binary field
|
|
REM get type name from metadata
|
|
|
|
Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object
|
|
Dim bNullable As Boolean, lSize As Long
|
|
Const cstMaxTextLength = 65535
|
|
Const cstMaxBinlength = 2 * 65535
|
|
|
|
On Local Error Goto 0 ' Disable error handler
|
|
vValue = Null ' Default value if error
|
|
If IsMissing(pbReturnBinary) Then pbReturnBinary = False
|
|
With com.sun.star.sdbc.DataType
|
|
iType = poResultSet.MetaData.getColumnType(piColIndex)
|
|
bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
|
Select Case iType
|
|
Case .ARRAY : vValue = poResultSet.getArray(piColIndex)
|
|
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
|
Set oValue = poResultSet.getBinaryStream(piColIndex)
|
|
If bNullable Then
|
|
If Not poResultSet.wasNull() Then
|
|
If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
|
|
lSize = cstMaxBinLength
|
|
Else
|
|
lSize = CLng(oValue.getLength())
|
|
End If
|
|
If lSize <= cstMaxBinLength And pbReturnBinary Then
|
|
vValue = Array()
|
|
oValue.readBytes(vValue, lSize)
|
|
Else ' Return length of field, not content
|
|
vValue = lSize
|
|
End If
|
|
End If
|
|
End If
|
|
oValue.closeInput()
|
|
Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(piColIndex)
|
|
Case .DATE : vDateTime = poResultSet.getDate(piColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
|
|
Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
|
|
vValue = Null
|
|
Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(piColIndex)
|
|
Case .FLOAT : vValue = poResultSet.getFloat(piColIndex)
|
|
Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(piColIndex)
|
|
Case .BIGINT : vValue = poResultSet.getLong(piColIndex)
|
|
Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(piColIndex)
|
|
Case .SQLNULL : vValue = poResultSet.getNull(piColIndex)
|
|
Case .OBJECT, .OTHER, .STRUCT : vValue = Null
|
|
Case .REF : vValue = poResultSet.getRef(piColIndex)
|
|
Case .TINYINT : vValue = poResultSet.getShort(piColIndex)
|
|
Case .CHAR, .VARCHAR : vValue = poResultSet.getString(piColIndex)
|
|
Case .LONGVARCHAR, .CLOB
|
|
Set oValue = poResultSet.getCharacterStream(piColIndex)
|
|
If bNullable Then
|
|
If Not poResultSet.wasNull() Then
|
|
If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
|
|
lSize = cstMaxTextLength
|
|
Else
|
|
lSize = CLng(oValue.getLength())
|
|
End If
|
|
oValue.closeInput()
|
|
vValue = poResultSet.getString(piColIndex)
|
|
End If
|
|
Else
|
|
oValue.closeInput()
|
|
End If
|
|
Case .TIME : vDateTime = poResultSet.getTime(piColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
|
|
Case .TIMESTAMP : vDateTime = poResultSet.getTimeStamp(piColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
|
|
+ TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
|
|
Case Else
|
|
vValue = poResultSet.getString(piColIndex) 'GIVE STRING A TRY
|
|
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
|
|
End Select
|
|
If bNullable Then
|
|
If poResultSet.wasNull() Then vValue = Null
|
|
End If
|
|
End With
|
|
|
|
_GetResultSetColumnValue = vValue
|
|
|
|
End Function ' GetResultSetColumnValue V 1.5.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _FinalProperty(psShortcut As String) As String
|
|
' Return the final property of a shortcut
|
|
|
|
Const cstEXCLAMATION = "!"
|
|
Const cstDOT = "."
|
|
|
|
Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
|
|
Dim sComponents() As String, sSubComponents() As String
|
|
_FinalProperty = ""
|
|
sComponents = Split(Trim(psShortcut), cstEXCLAMATION)
|
|
If UBound(sComponents) = 0 Then Exit Function
|
|
sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
|
|
Select Case UBound(sSubComponents)
|
|
Case 1
|
|
_FinalProperty = sSubComponents(1)
|
|
Case Else
|
|
Exit Function
|
|
End Select
|
|
|
|
End Function ' FinalProperty
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _GetProductName(ByVal Optional psFlag As String) as String
|
|
'Return OO product ("PRODUCT") and version numbers ("VERSION")
|
|
'Derived from Tools library
|
|
|
|
Dim oProdNameAccess as Object
|
|
Dim sVersion as String
|
|
Dim sProdName as String
|
|
If IsMissing(psFlag) Then psFlag = "ALL"
|
|
oProdNameAccess = _GetRegistryKeyContent("org.openoffice.Setup/Product")
|
|
sProdName = oProdNameAccess.getByName("ooName")
|
|
sVersion = oProdNameAccess.getByName("ooSetupVersionAboutBox")
|
|
Select Case psFlag
|
|
Case "ALL" : _GetProductName = sProdName & " " & sVersion
|
|
Case "PRODUCT" : _GetProductName = sProdName
|
|
Case "VERSION" : _GetProductName = sVersion
|
|
End Select
|
|
End Function ' GetProductName V1.0.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _GetRandomFileName(ByVal psName As String) As String
|
|
' Return the full name of a random temporary file suffixed by psName
|
|
|
|
Dim sRandom As String
|
|
sRandom = Right("000000" & Int(999999 * Rnd), 6)
|
|
_GetRandomFileName = Utils._getTempDirectoryURL() & "/" & "A2B_TEMP_" & psName & "_" & sRandom
|
|
|
|
End Function ' GetRandomFileName
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant
|
|
'Implement ConfigurationProvider service
|
|
'Derived from Tools library
|
|
|
|
Dim oConfigProvider as Object
|
|
Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
|
|
oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
|
|
aNodePath(0).Name = "nodepath"
|
|
aNodePath(0).Value = sKeyName
|
|
If IsMissing(bForUpdate) Then bForUpdate = False
|
|
If bForUpdate Then
|
|
_GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath())
|
|
Else
|
|
_GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
|
|
End If
|
|
End Function ' GetRegistryKeyContent V0.8.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _getTempDirectoryURL() As String
|
|
' Return the temporary directory defined in the OO Options (Paths)
|
|
Dim sDirectory As String, oSettings As Object, oPathSettings As Object
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
_getTempDirectoryURL = ""
|
|
oPathSettings = createUnoService( "com.sun.star.util.PathSettings" )
|
|
sDirectory = oPathSettings.GetPropertyValue( "Temp" )
|
|
|
|
_getTempDirectoryURL = sDirectory
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError("ERROR", Err, "_getTempDirectoryURL", Erl)
|
|
_getTempDirectoryURL = ""
|
|
Goto Exit_Function
|
|
End Function ' _getTempDirectoryURL V0.8.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _getUNOTypeName(pvObject As Variant) As String
|
|
' Return the symbolic name of the pvObject (UNO-object) type
|
|
' Code-snippet from XRAY
|
|
|
|
Dim oService As Object, vClass as Variant
|
|
_getUNOTypeName = ""
|
|
On Local Error Resume Next
|
|
oService = CreateUnoService("com.sun.star.reflection.CoreReflection")
|
|
vClass = oService.getType(pvObject)
|
|
If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then
|
|
_getUNOTypeName = vClass.Name
|
|
End If
|
|
oService.Dispose()
|
|
|
|
End Function ' getUNOTypeName
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean
|
|
' Return true if pvObject has the (UNO) method psMethod
|
|
' Code-snippet found in Bernard Marcelly's XRAY
|
|
|
|
Dim vInspect as Variant
|
|
_hasUNOMethod = False
|
|
If IsNull(pvObject) Then Exit Function
|
|
On Local Error Resume Next
|
|
vInspect = _A2B_.Introspection.Inspect(pvObject)
|
|
_hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL)
|
|
|
|
End Function ' hasUNOMethod V0.8.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean
|
|
' Return true if pvObject has the (UNO) property psProperty
|
|
' Code-snippet found in Bernard Marcelly's XRAY
|
|
|
|
Dim vInspect as Variant
|
|
_hasUNOProperty = False
|
|
If IsNull(pvObject) Then Exit Function
|
|
On Local Error Resume Next
|
|
vInspect = _A2B_.Introspection.Inspect(pvObject)
|
|
_hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
|
|
|
|
End Function ' hasUNOProperty V0.8.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _ImplementationName(pvObject As Variant) As String
|
|
' Use getImplementationName method or _getUNOTypeName function
|
|
|
|
Dim sObjectType As String
|
|
On Local Error Resume Next
|
|
sObjectType = pvObject.getImplementationName()
|
|
If sObjectType = "" Then sObjectType = _getUNOTypeName(pvObject)
|
|
|
|
_ImplementationName = sObjectType
|
|
|
|
End Function ' ImplementationName
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant
|
|
' Return True if pvItem is present in the pvList array (case insensitive comparison)
|
|
' Return the value in pvList if pvReturnValue = True
|
|
|
|
Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer
|
|
Dim iTop As Integer, iBottom As Integer, iFound As Integer
|
|
iItemVarType = VarType(pvItem)
|
|
If IsMissing(pvReturnValue) Then pvReturnValue = False
|
|
If iItemVarType = vbNull Or IsNull(pvList) Then
|
|
_InList = False
|
|
ElseIf Not IsArray(pvList) Then
|
|
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList )
|
|
If Not pvReturnValue Then
|
|
_InList = bFound
|
|
Else
|
|
If bFound Then _InList = pvList Else _InList = False
|
|
End If
|
|
ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized
|
|
_InList = False
|
|
Else
|
|
bFound = False
|
|
_InList = False
|
|
iListVarType = VarType(pvList(LBound(pvList)))
|
|
If iListVarType = iItemVarType _
|
|
Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _
|
|
Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _
|
|
And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _
|
|
Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _
|
|
) Then
|
|
If IsMissing(pbBinarySearch) Then pbBinarySearch = False
|
|
If Not pbBinarySearch Then ' Linear search
|
|
For i = LBound(pvList) To UBound(pvList)
|
|
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) )
|
|
If bFound Then
|
|
iFound = i
|
|
Exit For
|
|
End If
|
|
Next i
|
|
Else ' Binary search => array must be sorted
|
|
iTop = UBound(pvList)
|
|
iBottom = lBound(pvList)
|
|
Do
|
|
iFound = (iTop + iBottom) / 2
|
|
If ( iItemVarType = vbString And UCase(pvItem) > UCase(pvList(iFound)) ) Or ( iItemVarType <> vbString And pvItem > pvList(iFound) ) Then
|
|
iBottom = iFound + 1
|
|
Else
|
|
iTop = iFound - 1
|
|
End If
|
|
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) )
|
|
Loop Until ( bFound ) Or ( iBottom > iTop )
|
|
End If
|
|
If bFound Then
|
|
If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound)
|
|
End If
|
|
End If
|
|
End If
|
|
|
|
Exit Function
|
|
|
|
End Function ' InList V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String
|
|
'Return type of property EVEN WHEN EMPTY ! (Used in date and time controls)
|
|
|
|
Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object
|
|
' On Local Error Resume Next
|
|
_InspectPropertyType = ""
|
|
Set oInspect1 = CreateUnoService("com.sun.star.script.Invocation")
|
|
Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection
|
|
If Not IsNull(oInspect2) Then
|
|
Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
|
|
If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name
|
|
End If
|
|
Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing
|
|
|
|
End Function ' InspectPropertyType V1.0.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _IsLeft(psString As String, psLeft As String) As Boolean
|
|
' Return True if left part of psString = psLeft
|
|
|
|
Dim iLength As Integer
|
|
iLength = Len(psLeft)
|
|
_IsLeft = False
|
|
If Len(psString) >= iLength Then
|
|
If Left(psString, iLength) = psLeft Then _IsLeft = True
|
|
End If
|
|
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _IsBinaryType(ByVal lType As Long) As Boolean
|
|
|
|
With com.sun.star.sdbc.DataType
|
|
Select Case lType
|
|
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
|
_IsBinaryType = True
|
|
Case Else
|
|
_IsBinaryType = False
|
|
End Select
|
|
End With
|
|
|
|
End Function ' IsBinaryType V1.6.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean
|
|
' Test pvObject: does it exist ?
|
|
' is the _Type item = one of the proposed pvTypes ?
|
|
' does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ?
|
|
|
|
Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Exit_False
|
|
|
|
_IsPseudo = False
|
|
bIsPseudo = False
|
|
vObject = pvObject ' To avoid "Object variable not set" error message
|
|
Select Case True
|
|
Case IsEmpty(vObject)
|
|
Case IsNull(vObject)
|
|
Case VarType(vObject) <> vbObject
|
|
Case Else
|
|
With vObject
|
|
Select Case True
|
|
Case IsEmpty(._Type)
|
|
Case IsNull(._Type)
|
|
Case ._Type = ""
|
|
Case Else
|
|
bIsPseudo = _InList(._Type, pvType)
|
|
If Not bIsPseudo Then ' If primary type did not succeed, give the subtype a chance
|
|
If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType)
|
|
End If
|
|
End Select
|
|
End With
|
|
End Select
|
|
|
|
If Not bIsPseudo Then Goto Exit_Function
|
|
|
|
Dim oDoc As Object, oForms As Variant
|
|
Const cstSeparator = "\;"
|
|
|
|
bPseudoExists = False
|
|
With vObject
|
|
Select Case ._Type
|
|
Case OBJFORM
|
|
If ._Name <> "" Then ' Check validity of form name
|
|
Set oDoc = _A2B_.CurrentDocument()
|
|
If oDoc.DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = _InList(._Name, Application._GetAllHierarchicalNames())
|
|
End If
|
|
Case OBJDATABASE
|
|
If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection)
|
|
Case OBJDIALOG
|
|
If ._Name <> "" Then ' Check validity of dialog name
|
|
bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) )
|
|
End If
|
|
Case OBJCOLLECTION
|
|
bPseudoExists = True
|
|
Case OBJCONTROL
|
|
If Not IsNull(.ControlModel) And ._Name <> "" Then ' Check validity of control
|
|
Set oForms = .ControlModel.Parent
|
|
bPseudoExists = ( oForms.hasByName(._Name) )
|
|
End If
|
|
Case OBJSUBFORM
|
|
If Not IsNull(.DatabaseForm) And ._Name <> "" Then ' Check validity of subform
|
|
If .DatabaseForm.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then
|
|
Set oForms = .DatabaseForm.Parent
|
|
bPseudoExists = ( oForms.hasByName(._Name) )
|
|
End If
|
|
End If
|
|
Case OBJOPTIONGROUP
|
|
bPseudoExists = ( .Count > 0 )
|
|
Case OBJCOMMANDBAR
|
|
bPseudoExists = ( Not IsNull(._Window) )
|
|
Case OBJCOMMANDBARCONTROL
|
|
bPseudoExists = ( Not IsNull(._ParentCommandBar) )
|
|
Case OBJEVENT
|
|
bPseudoExists = ( Not IsNull(._EventSource) )
|
|
Case OBJPROPERTY
|
|
bPseudoExists = ( ._Name <> "" )
|
|
Case OBJTABLEDEF
|
|
bPseudoExists = ( ._Name <> "" And Not IsNull(.Table) )
|
|
Case OBJQUERYDEF
|
|
bPseudoExists = ( ._Name <> "" And Not IsNull(.Query) )
|
|
Case OBJRECORDSET
|
|
bPseudoExists = ( Not IsNull(.RowSet) )
|
|
Case OBJFIELD
|
|
bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) )
|
|
Case OBJTEMPVAR
|
|
If ._Name <> "" Then ' Check validity of tempvar name
|
|
bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) )
|
|
End If
|
|
Case Else
|
|
End Select
|
|
End With
|
|
|
|
_IsPseudo = ( bIsPseudo And bPseudoExists )
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Exit_False:
|
|
_IsPseudo = False
|
|
Goto Exit_Function
|
|
End Function ' IsPseudo V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _IsScalar(ByVal pvArg As Variant, ByVal pvType As Variant, ByVal Optional pvValid As Variant) As Boolean
|
|
' Check type of pvArg and value in allowed pvValid list
|
|
|
|
_IsScalar = False
|
|
|
|
If IsArray(pvType) Then
|
|
If Not _InList(VarType(pvArg), pvType) Then Exit Function
|
|
ElseIf VarType(pvArg) <> pvType Then
|
|
If pvType = vbBoolean And VarType(pvArg) = vbLong Then
|
|
If pvArg < -1 And pvArg > 0 Then Exit Function ' Special boolean processing because the Not function returns a Long
|
|
Else
|
|
Exit Function
|
|
End If
|
|
End If
|
|
If Not IsMissing(pvValid) Then
|
|
If Not _InList(pvArg, pvValid) Then Exit Function
|
|
End If
|
|
|
|
_IsScalar = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
End Function ' IsScalar V0.7.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _PCase(ByVal psString As String) As String
|
|
' Return the proper case representation of argument
|
|
|
|
Dim vSubStrings() As Variant, i As Integer, iLen As Integer
|
|
vSubStrings = Split(psString, " ")
|
|
For i = 0 To UBound(vSubStrings)
|
|
iLen = Len(vSubStrings(i))
|
|
If iLen > 1 Then
|
|
vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) & LCase(Right(vSubStrings(i), iLen - 1))
|
|
ElseIf iLen = 1 Then
|
|
vSubStrings(i) = UCase(vSubStrings(i))
|
|
End If
|
|
Next i
|
|
_PCase = Join(vSubStrings, " ")
|
|
|
|
End Function ' PCase V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _PercentEncode(ByVal psChar As String) As String
|
|
' Percent encoding of single psChar character
|
|
' https://en.wikipedia.org/wiki/UTF-8
|
|
|
|
Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
|
|
lChar = Asc(psChar)
|
|
|
|
Select Case lChar
|
|
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z
|
|
_PercentEncode = psChar
|
|
Case Asc("-"), Asc("."), Asc("_"), Asc("~")
|
|
_PercentEncode = psChar
|
|
Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings
|
|
_PercentEncode = psChar
|
|
Case Asc(" "), Asc("%")
|
|
_PercentEncode = "%" & Right("00" & Hex(lChar), 2)
|
|
Case 0 To 127
|
|
_PercentEncode = psChar
|
|
Case 128 To 2047
|
|
sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2)
|
|
sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
|
|
_PercentEncode = sByte1 & sByte2
|
|
Case 2048 To 65535
|
|
sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2)
|
|
sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
|
|
sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
|
|
_PercentEncode = sByte1 & sByte2 & sByte3
|
|
Case Else ' Not supported
|
|
_PercentEncode = psChar
|
|
End Select
|
|
|
|
Exit Function
|
|
|
|
End Function ' _PercentEncode V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
|
|
' Loads all lines of a text file into a Variant array
|
|
' Any error reduces output to an empty array
|
|
' Input file name presumed in URL form
|
|
|
|
Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer
|
|
Const cstMaxLines = 16000 ' +/- the limit of array sizes in Basic
|
|
On Local Error GoTo Error_Function
|
|
vLines = Array()
|
|
_ReadFileIntoArray = Array()
|
|
If psFileName = "" Then Exit Function
|
|
|
|
iFile = FreeFile()
|
|
Open psFileName For Input Access Read Shared As #iFile
|
|
iCount1 = 0
|
|
Do While Not Eof(iFile) And iCount1 < cstMaxLines
|
|
Line Input #iFile, sLine
|
|
iCount1 = iCount1 + 1
|
|
Loop
|
|
Close #iFile
|
|
|
|
ReDim vLines(0 To iCount1 - 1) ' Reading file twice preferred to ReDim Preserve for performance reasons
|
|
iFile = FreeFile()
|
|
Open psFileName For Input Access Read Shared As #iFile
|
|
iCount2 = 0
|
|
Do While Not Eof(iFile) And iCount2 < iCount1
|
|
Line Input #iFile, vLines(iCount2)
|
|
iCount2 = iCount2 + 1
|
|
Loop
|
|
Close #iFile
|
|
|
|
Exit_Function:
|
|
_ReadFileIntoArray() = vLines()
|
|
Exit Function
|
|
Error_Function:
|
|
vLines = Array()
|
|
Resume Exit_Function
|
|
End Function ' _ReadFileIntoArray V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _RegexSearch(ByRef psString As String _
|
|
, ByVal psRegex As String _
|
|
, Optional ByRef plStart As Long _
|
|
, Optional ByVal bForward As Boolean _
|
|
) As String
|
|
' Search is not case-sensitive
|
|
' Return "" if regex not found, otherwise returns the matching string
|
|
' plStart = start position of psString to search (starts at 1)
|
|
' In output plStart contains the first position of the matching string
|
|
' To search again the same or another pattern => plStart = plStart + Len(matching string)
|
|
|
|
Dim oTextSearch As Object
|
|
Dim vOptions As Variant 'com.sun.star.util.SearchOptions
|
|
Dim lEnd As Long, vResult As Object
|
|
|
|
_RegexSearch = ""
|
|
Set oTextSearch = _A2B_.TextSearch ' UNO XTextSearch service
|
|
vOptions = _A2B_.SearchOptions
|
|
vOptions.searchString = psRegex ' Pattern to be searched
|
|
oTextSearch.setOptions(vOptions)
|
|
If IsMissing(plStart) Then plStart = 1
|
|
If plStart <= 0 Or plStart > Len(psString) Then Exit Function
|
|
If IsMissing(bForWard) Then bForward = True
|
|
If bForward Then
|
|
lEnd = Len(psString)
|
|
vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
|
|
Else
|
|
lEnd = 1
|
|
vResult = oTextSearch.searchForward(psString, plStart, lEnd - 1)
|
|
End If
|
|
With vResult
|
|
If .subRegExpressions >= 1 Then
|
|
' http://www.openoffice.org/api/docs/common/ref/com/sun/star/util/SearchResult.html
|
|
Select Case bForward
|
|
Case True
|
|
plStart = .startOffset(0) + 1
|
|
lEnd = .endOffset(0) + 1
|
|
Case False
|
|
plStart = .endOffset(0) + 1
|
|
lEnd = .startOffset(0)
|
|
End Select
|
|
_RegexSearch = Mid(psString, plStart, lEnd - plStart)
|
|
Else
|
|
plStart = 0
|
|
End If
|
|
End With
|
|
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _RegisterDialogEventScript(poObject As Object _
|
|
, ByVal psEvent As String _
|
|
, ByVal psListener As String _
|
|
, ByVal psScriptCode As String _
|
|
) As Boolean
|
|
' Register a script event (psEvent) to poObject (Dialog or dialog Control)
|
|
|
|
Dim oEvents As Object, sEvent As String, sEventName As String, oEvent As Object
|
|
|
|
_RegisterDialogEventScript = False
|
|
If Not _hasUNOMethod(poObject, "getEvents") Then Exit Function
|
|
|
|
' Remove existing event, if any, then store new script code
|
|
Set oEvents = poObject.getEvents()
|
|
sEvent = Utils._GetEventName(psEvent)
|
|
sEventName = "com.sun.star.awt." & psListener & "::" & sEvent
|
|
If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName)
|
|
Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
|
|
With oEvent
|
|
.ListenerType = psListener
|
|
.EventMethod = sEvent
|
|
.ScriptType = "Script" ' Better than "Basic"
|
|
.ScriptCode = psScriptCode
|
|
End With
|
|
oEvents.insertByName(sEventName, oEvent)
|
|
|
|
_RegisterDialogEventScript = True
|
|
|
|
End Function ' _RegisterDialogEventScript V1.8.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _RegisterEventScript(poObject As Object _
|
|
, ByVal psEvent As String _
|
|
, ByVal psListener As String _
|
|
, ByVal psScriptCode As String _
|
|
, ByVal psName As String _
|
|
, Optional ByVal pbExtendName As Boolean _
|
|
) As Boolean
|
|
' Register a script event (psEvent) to poObject (Form, SubForm or Control)
|
|
|
|
Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String
|
|
|
|
_RegisterEventScript = False
|
|
If Not _hasUNOMethod(poObject, "getParent") Then Exit Function
|
|
|
|
' Find object internal index i.e. how to reach it via getByIndex()
|
|
If IsMissing(pbExtendName) Then pbExtendName = False
|
|
Set oParent = poObject.getParent()
|
|
iIndex = -1
|
|
For i = 0 To oParent.getCount() - 1
|
|
sName = oParent.getByIndex(i).Name
|
|
If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
|
|
iIndex = i
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If iIndex < 0 Then Exit Function
|
|
|
|
sEvent = Utils._GetEventName(psEvent) ' Targeted event method
|
|
If psScriptCode = "" Then
|
|
oParent.revokeScriptEvent(iIndex, psListener, sEvent, "")
|
|
Else
|
|
Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
|
|
With oEvent
|
|
.ListenerType = psListener
|
|
.EventMethod = sEvent
|
|
.ScriptType = "Script" ' Better than "Basic"
|
|
.ScriptCode = psScriptCode
|
|
End With
|
|
oParent.registerScriptEvent(iIndex, oEvent)
|
|
End If
|
|
_RegisterEventScript = True
|
|
|
|
End Function ' _RegisterEventScript V1.7.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub _ResetCalledSub(ByVal psSub As String)
|
|
' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
|
|
' Used to trace routine in/outs and to clarify error messages
|
|
If IsEmpty(_A2B_) Then Call Application._RootInit() ' Only when Utils module recompiled
|
|
With _A2B_
|
|
If .CalledSub = psSub Then .CalledSub = ""
|
|
If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False)
|
|
End With
|
|
End Sub ' ResetCalledSub
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean
|
|
' Execute a given script with pvArgs() array of arguments
|
|
|
|
On Local Error Goto Error_Function
|
|
_RunScript = False
|
|
If IsNull(ThisComponent) Then Goto Exit_Function
|
|
|
|
Dim oSCriptProvider As Object, oScript As Object, vResult As Variant
|
|
|
|
Set oScriptProvider = ThisComponent.ScriptProvider()
|
|
Set oScript = oScriptProvider.getScript(psScript)
|
|
If IsMissing(pvArgs()) Then pvArgs() = Array()
|
|
vResult = oScript.Invoke(pvArgs(), Array(), Array())
|
|
_RunScript = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
_RunScript = False
|
|
Goto Exit_Function
|
|
End Function
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub _SetCalledSub(ByVal psSub As String)
|
|
' Called in top of each public function.
|
|
' Used to trace routine in/outs and to clarify error messages
|
|
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
|
|
With _A2B_
|
|
If .CalledSub = "" Then
|
|
.CalledSub = psSub
|
|
.LastErrorCode = 0
|
|
.LastErrorLevel = ""
|
|
.ErrorText = ""
|
|
.ErrorLongText = ""
|
|
End If
|
|
If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False)
|
|
End With
|
|
End Sub ' SetCalledSub
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _Surround(ByVal psName As String) As String
|
|
' Return [Name] if Name contains spaces
|
|
' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots
|
|
|
|
Const cstSquareOpen = "["
|
|
Const cstSquareClose = "]"
|
|
Const cstDot = "."
|
|
Dim sName As String
|
|
|
|
If InStr(psName, ".") > 0 Then
|
|
sName = Join(Split(psName, cstDot), cstSquareClose & cstDot & cstSquareOpen)
|
|
_Surround = cstSquareOpen & sName & cstSquareClose
|
|
ElseIf InStr(psName, " ") > 0 Then
|
|
_Surround = cstSquareOpen & psName & cstSquareClose
|
|
Else
|
|
_Surround = psName
|
|
End If
|
|
|
|
End Function ' Surround
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _Trim(ByVal psString As String) As String
|
|
' Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces
|
|
Const cstSquareOpen = "["
|
|
Const cstSquareClose = "]"
|
|
Dim sTrim As String
|
|
|
|
sTrim = Trim(Replace(psString, vbTab, " "))
|
|
_Trim = sTrim
|
|
If Len(sTrim) <= 2 Then Exit Function
|
|
|
|
If Left(sTrim, 1) = cstSquareOpen Then
|
|
If Right(sTrim, 1) = cstSquareClose Then
|
|
_Trim = Mid(sTrim, 2, Len(sTrim) - 2)
|
|
End If
|
|
End If
|
|
End Function ' Trim V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _TrimArray(pvArray As Variant) As Variant
|
|
' Remove empty strings from strings array
|
|
|
|
Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer
|
|
vTrim = Null
|
|
If Not IsArray(pvArray) Then
|
|
If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array()
|
|
ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty
|
|
vTrim = Array()
|
|
Else
|
|
iCount = 0
|
|
For i = LBound(pvArray) To UBound(pvArray)
|
|
If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1
|
|
Next i
|
|
If iCount = 0 Then
|
|
vTrim() = pvArray()
|
|
ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks
|
|
vTrim() = Array()
|
|
Else
|
|
ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount)
|
|
j = 0
|
|
For i = LBound(pvArray) To UBound(pvArray)
|
|
If Len(Trim(pvArray(i))) > 0 Then
|
|
vTrim(j) = pvArray(i)
|
|
j = j + 1
|
|
End If
|
|
Next i
|
|
End If
|
|
End If
|
|
|
|
_TrimArray() = vTrim()
|
|
|
|
End Function ' TrimArray V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _
|
|
, poResultSet As Object _
|
|
, ByVal piColIndex As Integer _
|
|
, ByVal pvValue As Variant _
|
|
) As Boolean
|
|
REM store the pvValue for the column specified by ColIndex
|
|
REM get type name from metadata
|
|
|
|
Dim iType As Integer, vDateTime As Variant, oValue As Object
|
|
Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String
|
|
Const cstMaxTextLength = 65535
|
|
Const cstMaxBinlength = 2 * 65535
|
|
|
|
On Local Error Goto 0 ' Disable error handler
|
|
_UpdateResultSetColumnValue = False
|
|
With com.sun.star.sdbc.DataType
|
|
iType = poResultSet.MetaData.getColumnType(piColIndex)
|
|
iValueType = VarType(pvValue)
|
|
sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex))
|
|
bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
|
|
|
If bNullable And IsNull(pvValue) Then
|
|
poResultSet.updateNull(piColIndex)
|
|
Else
|
|
Select Case iType
|
|
Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT
|
|
poResultSet.updateNull(piColIndex)
|
|
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
|
poResultSet.updateBytes(piColIndex, pvValue)
|
|
Case .BIT, .BOOLEAN : poResultSet.updateBoolean(piColIndex, pvValue)
|
|
Case .DATE : vDateTime = CreateUnoStruct("com.sun.star.util.Date")
|
|
vDateTime.Year = Year(pvValue)
|
|
vDateTime.Month = Month(pvValue)
|
|
vDateTime.Day = Day(pvValue)
|
|
poResultSet.updateDate(piColIndex, vDateTime)
|
|
Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
|
|
Case .DOUBLE, .REAL : poResultSet.updateDouble(piColIndex, pvValue)
|
|
Case .FLOAT : poResultSet.updateFloat(piColIndex, pvValue)
|
|
Case .INTEGER, .SMALLINT : poResultSet.updateInt(piColIndex, pvValue)
|
|
Case .BIGINT : poResultSet.updateLong(piColIndex, pvValue)
|
|
Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
|
|
Case .TINYINT : poResultSet.updateShort(piColIndex, pvValue)
|
|
Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
|
|
If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, "BINARY") > 0 Then ' Sqlite exception ... !
|
|
poResultSet.updateBytes(piColIndex, pvValue)
|
|
Else
|
|
poResultSet.updateString(piColIndex, pvValue)
|
|
End If
|
|
Case .TIME : vDateTime = CreateUnoStruct("com.sun.star.util.Time")
|
|
vDateTime.Hours = Hour(pvValue)
|
|
vDateTime.Minutes = Minute(pvValue)
|
|
vDateTime.Seconds = Second(pvValue)
|
|
'vDateTime.HundredthSeconds = 0
|
|
poResultSet.updateTime(piColIndex, vDateTime)
|
|
Case .TIMESTAMP : vDateTime = CreateUnoStruct("com.sun.star.util.DateTime")
|
|
vDateTime.Year = Year(pvValue)
|
|
vDateTime.Month = Month(pvValue)
|
|
vDateTime.Day = Day(pvValue)
|
|
vDateTime.Hours = Hour(pvValue)
|
|
vDateTime.Minutes = Minute(pvValue)
|
|
vDateTime.Seconds = Second(pvValue)
|
|
'vDateTime.HundredthSeconds = 0
|
|
poResultSet.updateTimestamp(piColIndex, vDateTime)
|
|
Case Else
|
|
If bNullable Then poResultSet.updateNull(piColIndex)
|
|
End Select
|
|
End If
|
|
|
|
End With
|
|
|
|
_UpdateResultSetColumnValue = True
|
|
|
|
End Function ' UpdateResultSetColumnValue V 1.6.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _URLEncode(ByVal psToEncode As String) As String
|
|
' http://www.w3schools.com/tags/ref_urlencode.asp
|
|
' http://xkr.us/articles/javascript/encode-compare/
|
|
' http://tools.ietf.org/html/rfc3986
|
|
|
|
Dim sEncoded As String, sChar As String
|
|
Dim lCurrentChar As Long, bQuestionMark As Boolean
|
|
|
|
sEncoded = ""
|
|
bQuestionMark = False
|
|
For lCurrentChar = 1 To Len(psToEncode)
|
|
sChar = Mid(psToEncode, lCurrentChar, 1)
|
|
Select Case sChar
|
|
Case " ", "%"
|
|
sEncoded = sEncoded & _PercentEncode(sChar)
|
|
Case "?" ' Is it the first "?" ?
|
|
If bQuestionMark Then ' "?" introduces in a URL the arguments part
|
|
sEncoded = sEncoded & _PercentEncode(sChar)
|
|
Else
|
|
sEncoded = sEncoded & sChar
|
|
bQuestionMark = True
|
|
End If
|
|
Case "\"
|
|
If bQuestionMark Then
|
|
sEncoded = sEncoded & _PercentEncode(sChar)
|
|
Else
|
|
sEncoded = sEncoded & "/" ' If Windows file naming ...
|
|
End If
|
|
Case Else
|
|
If bQuestionMark Then
|
|
sEncoded = sEncoded & _PercentEncode(sChar)
|
|
Else
|
|
sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL
|
|
End If
|
|
End Select
|
|
Next lCurrentChar
|
|
|
|
_URLEncode = sEncoded
|
|
|
|
End Function ' _URLEncode V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _UTF8Encode(ByVal psChar As String) As String
|
|
' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent
|
|
' http://www.w3schools.com/charsets/ref_html_utf8.asp
|
|
|
|
Select Case psChar
|
|
Case """" : _UTF8Encode = "&quot;"
|
|
Case "&" : _UTF8Encode = "&amp;"
|
|
Case "<" : _UTF8Encode = "&lt;"
|
|
Case ">" : _UTF8Encode = "&gt;"
|
|
Case "'" : _UTF8Encode = "&apos;"
|
|
Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters
|
|
_UTF8Encode = psChar
|
|
Case Chr(13) : _UTF8Encode = "" ' Carriage return
|
|
Case Chr(10) : _UTF8Encode = "<br>" ' Line Feed
|
|
Case < Chr(126) : _UTF8Encode = psChar
|
|
Case "€" : _UTF8Encode = "&euro;"
|
|
Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";"
|
|
End Select
|
|
|
|
Exit Function
|
|
|
|
End Function ' _UTF8Encode V1.4.0
|
|
|
|
</script:module> |