diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
| commit | 940b4d1848e8c70ab7642901a68594e8016caffc (patch) | |
| tree | eb72f344ee6c3d9b80a7ecc079ea79e9fba8676d /wizards/source/access2base/Utils.xba | |
| parent | Initial commit. (diff) | |
| download | libreoffice-1ad18e38974bb28c3d98d0be8f7d8c18fc56de29.tar.xz libreoffice-1ad18e38974bb28c3d98d0be8f7d8c18fc56de29.zip | |
Adding upstream version 1:7.0.4.upstream/1%7.0.4upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'wizards/source/access2base/Utils.xba')
| -rw-r--r-- | wizards/source/access2base/Utils.xba | 1306 |
1 files changed, 1306 insertions, 0 deletions
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba new file mode 100644 index 000000000..b5dee5214 --- /dev/null +++ b/wizards/source/access2base/Utils.xba @@ -0,0 +1,1306 @@ +<?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 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 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 ----------------------------------------------------------------------------------------------------------------------- +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>
\ No newline at end of file |