D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
lib
/
libreoffice
/
share
/
basic
/
Access2Base
/
Filename :
Utils.xba
back
Copy
<?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>