EVOLUTION-MANAGER
Edit File: 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 '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 If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType) If iVarType = vbString Then ' pvType is a pseudo-type string _CheckArgument = Utils._IsPseudo(pvItem, pvType) Else If IsMissing(pvValid) Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid) End If If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem) 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 rejected 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 IsArray(pvArg) Then If VarType(pvArg) = vbByte Or VarType(pvArg) - 8192 = vbByte Then sArg = "" 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 sArg = "[ARRAY]" 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 : sArg = pvArg Case vbBoolean : sArg = Iif(pvArg, "TRUE", "FALSE") Case vbByte : sArg = Right("00" & Hex(pvArg), 2) Case Else : sArg = CStr(pvArg) End Select End If If IsMissing(pbShort) Then pbShort = True 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 _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 http://wiki.services.openoffice.org/wiki/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 ----------------------------------------------------------------------------------------------------------------------- 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() If lSize <= cstMaxBinLength Then vValue = poResultSet.getString(piColIndex) Else vValue = "" 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 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 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 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 Set oForms = oDoc.Document.getFormDocuments() bPseudoExists = ( oForms.HasByName(._Name) ) End If 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 delimitors 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 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 is Utils module recompiled If _A2B_.CalledSub = psSub Then _A2B_.CalledSub = "" If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False) 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 If _A2B_.CalledSub = "" Then _A2B_.CalledSub = psSub If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False) End Sub ' SetCalledSub REM ----------------------------------------------------------------------------------------------------------------------- Public Function _Surround(ByVal psName As String) As String ' Return [Name] if Name contains spaces ' 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 Const cstSquareOpen = "[" Const cstSquareClose = "]" Dim sTrim As String sTrim = Trim(psString) _Trim = sTrim If Len(sTrim) <= 2 Then Exit Function If Left(sTrim, 1) = cstSquareOpen Then If Right(sTrim, 1) = cstSquareClose Then _Trim = Mid(sTrim, 2, Len(sTrim) - 2) End If End If End Function ' Trim V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _TrimArray(pvArray As Variant) As Variant ' Remove empty strings from strings array Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer vTrim = Null If Not IsArray(pvArray) Then If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array() ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty vTrim = Array() Else iCount = 0 For i = LBound(pvArray) To UBound(pvArray) If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1 Next i If iCount = 0 Then vTrim() = pvArray() ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks vTrim() = Array() Else ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount) 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>