?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
cURL: follow redirects
[LibreOffice.git] / wizards / source / access2base / Utils.xba
blobda9e57f7ab736d6806fac33e75411908aea51118
1 <?xml version="1.0" encoding="UTF-8"?>
2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Utils" script:language="StarBasic">REM =======================================================================================================================
4 REM === The Access2Base library is a part of the LibreOffice project. ===
5 REM === Full documentation is available on http://www.access2base.com ===
6 REM =======================================================================================================================
7
8 Option Explicit
9
10 Global _A2B_ As Variant
11
12 REM -----------------------------------------------------------------------------------------------------------------------
13 REM --- PRIVATE FUNCTIONS ---
14 REM -----------------------------------------------------------------------------------------------------------------------
15
16 Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant
17 &apos;Add the item at the end of the array
18
19 Dim vArray() As Variant
20 If IsArray(pvArray) Then vArray = pvArray Else vArray = Array()
21 ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1)
22 vArray(UBound(vArray)) = pvItem
23 _AddArray() = vArray()
24
25 End Function
26
27 REM -----------------------------------------------------------------------------------------------------------------------
28 Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant
29 &apos;Return on top of argument the list of all numeric types
30 &apos;Facilitates the entry of the list of allowed types in _CheckArgument calls
31
32 Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer
33 If IsMissing(pvTypes) Then
34 vNewList = Array()
35 ElseIf IsArray(pvTypes) Then
36 vNewList = pvTypes
37 Else
38 vNewList = Array(pvTypes)
39 End If
40
41 vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean)
42
43 iSize = UBound(vNewlist)
44 ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1)
45 For i = 0 To UBound(vNumeric)
46 vNewList(iSize + i + 1) = vNumeric(i)
47 Next i
48
49 _AddNumeric = vNewList
50
51 End Function &apos; _AddNumeric V0.8.0
52
53 REM -----------------------------------------------------------------------------------------------------------------------
54
55 Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean
56
57 _BitShift = False
58 If piValue = 0 Then Exit Function
59 Select Case piConstant
60 Case 1
61 Select Case piValue
62 Case 1, 3, 5, 7, 9, 11, 13, 15: _BitShift = True
63 Case Else
64 End Select
65 Case 2
66 Select Case piValue
67 Case 2, 3, 6, 7, 10, 11, 14, 15: _BitShift = True
68 Case Else
69 End Select
70 Case 4
71 Select Case piValue
72 Case 4, 5, 6, 7, 12, 13, 14, 15: _BitShift = True
73 Case Else
74 End Select
75 Case 8
76 Select Case piValue
77 Case 8, 9, 10, 11, 12, 13, 14, 15: _BitShift = True
78 Case Else
79 End Select
80 End Select
81
82 End Function &apos; BitShift
83
84 REM -----------------------------------------------------------------------------------------------------------------------
85 Public Function _CalledSub() As String
86 _CalledSub = Iif(_A2B_.CalledSub = &quot;&quot;, &quot;&quot;, _GetLabel(&quot;CALLTO&quot;) &amp; &quot; &apos;&quot; &amp; _A2B_.CalledSub &amp; &quot;&apos;&quot;)
87 End Function &apos; CalledSub V0.8.9
88
89
90 REM -----------------------------------------------------------------------------------------------------------------------
91 Public Function _CheckArgument(pvItem As Variant _
92 , ByVal piArgNr As Integer _
93 , Byval pvType As Variant _
94 , ByVal Optional pvValid As Variant _
95 , ByVal Optional pvError As Boolean _
96 ) As Variant
97 &apos; Called by public functions to check the validity of their arguments
98 &apos; pvItem Argument to be checked
99 &apos; piArgNr Argument sequence number
100 &apos; pvType Single value or array of allowed variable types
101 &apos; If of string type must contain one or more valid pseudo-object types
102 &apos; pvValid Single value or array of allowed values - comparison for strings is case-insensitive
103 &apos; pvError If True (default), error handling in this routine. False in _setProperty methods in class modules.
104
105 _CheckArgument = False
106
107 Dim iVarType As Integer
108 If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType)
109 If iVarType = vbString Then &apos; pvType is a pseudo-type string
110 _CheckArgument = Utils._IsPseudo(pvItem, pvType)
111 Else
112 If IsMissing(pvValid) Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid)
113 End If
114
115 If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem)
116
117 Exit_Function:
118 If Not _CheckArgument Then
119 If IsMissing(pvError) Then pvError = True
120 If pvError Then
121 TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem))
122 End If
123 End If
124 Exit Function
125 End Function &apos; CheckArgument V0.9.0
126
127 REM -----------------------------------------------------------------------------------------------------------------------
128 Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
129 &apos; Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
130 &apos; pvArg may be a byte-array. Other arrays are rejected
131
132 Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
133 Const cstLength = 50
134 Const cstByteLength = 25
135 If IsArray(pvArg) Then
136 If VarType(pvArg) = vbByte Or VarType(pvArg) - 8192 = vbByte Then
137 sArg = &quot;&quot;
138 If pbShort And UBound(pvArg) &gt; cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
139 For i = 0 To iMax
140 sArg = sArg &amp; Right(&quot;00&quot; &amp; Hex(pvArg(i)), 2)
141 Next i
142 Else
143 sArg = &quot;[ARRAY]&quot;
144 End If
145 Else
146 Select Case VarType(pvArg)
147 Case vbEmpty : sArg = &quot;[EMPTY]&quot;
148 Case vbNull : sArg = &quot;[NULL]&quot;
149 Case vbObject
150 If IsNull(pvArg) Then
151 sArg = &quot;[NULL]&quot;
152 Else
153 sObject = Utils._ImplementationName(pvArg)
154 If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
155 , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _
156 , OBJDIALOG _
157 )) Then
158 Set oArg = pvArg &apos; To avoid &quot;Object variable not set&quot; error message
159 sArg = &quot;[&quot; &amp; oArg._Type &amp; &quot;] &quot; &amp; oArg._Name
160 ElseIf sObject &lt;&gt; &quot;&quot; Then
161 sArg = &quot;[&quot; &amp; sObject &amp; &quot;]&quot;
162 Else
163 sArg = &quot;[OBJECT]&quot;
164 End If
165 End If
166 Case vbVariant : sArg = &quot;[VARIANT]&quot;
167 Case vbString : sArg = pvArg
168 Case vbBoolean : sArg = Iif(pvArg, &quot;TRUE&quot;, &quot;FALSE&quot;)
169 Case vbByte : sArg = Right(&quot;00&quot; &amp; Hex(pvArg), 2)
170 Case Else : sArg = CStr(pvArg)
171 End Select
172 End If
173 If IsMissing(pbShort) Then pbShort = True
174 If pbShort And Len(sArg) &gt; cstLength Then
175 sLength = &quot;(&quot; &amp; Len(sArg) &amp; &quot;)&quot;
176 sArg = Left(sArg, cstLength - 5 - Len(slength)) &amp; &quot; ... &quot; &amp; sLength
177 End If
178 _CStr = sArg
179
180 End Function &apos; CStr V0.9.5
181
182 REM -----------------------------------------------------------------------------------------------------------------------
183 Public Function _DecimalPoint() As String
184 &apos;Return locale decimal point
185 _DecimalPoint = Mid(Format(0, &quot;0.0&quot;), 2, 1)
186 End Function
187
188 REM -----------------------------------------------------------------------------------------------------------------------
189 Private Function _ExtensionLocation() As String
190 &apos; Return the URL pointing to the location where OO installed the Access2Base extension
191 &apos; Adapted from http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/Extensions/Location_of_Installed_Extensions
192
193 Dim oPip As Object, sLocation As String
194 Set oPip = GetDefaultContext.getByName(&quot;/singletons/com.sun.star.deployment.PackageInformationProvider&quot;)
195 _ExtensionLocation = oPip.getPackageLocation(&quot;Access2Base&quot;)
196
197 End Function &apos; ExtensionLocation
198
199 REM -----------------------------------------------------------------------------------------------------------------------
200 Private Function _GetDialogLib() As Object
201 &apos; Return actual Access2Base dialogs library
202
203 Dim oDialogLib As Object
204
205 Set oDialogLib = DialogLibraries
206 If oDialogLib.hasByName(&quot;Access2BaseDev&quot;) Then
207 If Not oDialogLib.IsLibraryLoaded(&quot;Access2BaseDev&quot;) Then oDialogLib.loadLibrary(&quot;Access2BaseDev&quot;)
208 Set _GetDialogLib = DialogLibraries.Access2BaseDev
209 ElseIf oDialogLib.hasByName(&quot;Access2Base&quot;) Then
210 If Not oDialogLib.IsLibraryLoaded(&quot;Access2Base&quot;) Then oDialogLib.loadLibrary(&quot;Access2Base&quot;)
211 Set _GetDialogLib = DialogLibraries.Access2Base
212 Else
213 Set _GetDialogLib = Nothing
214 EndIf
215
216 End Function
217
218 REM -----------------------------------------------------------------------------------------------------------------------
219 Private Function _GetResultSetColumnValue(poResultSet As Object _
220 , ByVal piColIndex As Integer _
221 , Optional ByVal pbReturnBinary As Boolean _
222 ) As Variant
223 REM Modified from Roberto Benitez&apos;s BaseTools
224 REM get the data for the column specified by ColIndex
225 REM If pbReturnBinary = False (default) then return length of binary field
226 REM get type name from metadata
227
228 Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object
229 Dim bNullable As Boolean, lSize As Long
230 Const cstMaxTextLength = 65535
231 Const cstMaxBinlength = 2 * 65535
232
233 On Local Error Goto 0 &apos; Disable error handler
234 vValue = Null &apos; Default value if error
235 If IsMissing(pbReturnBinary) Then pbReturnBinary = False
236 With com.sun.star.sdbc.DataType
237 iType = poResultSet.MetaData.getColumnType(piColIndex)
238 bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
239 Select Case iType
240 Case .ARRAY : vValue = poResultSet.getArray(piColIndex)
241 Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
242 Set oValue = poResultSet.getBinaryStream(piColIndex)
243 If bNullable Then
244 If Not poResultSet.wasNull() Then
245 If Not _hasUNOMethod(oValue, &quot;getLength&quot;) Then &apos; When no recordset
246 lSize = cstMaxBinLength
247 Else
248 lSize = CLng(oValue.getLength())
249 End If
250 If lSize &lt;= cstMaxBinLength And pbReturnBinary Then
251 vValue = Array()
252 oValue.readBytes(vValue, lSize)
253 Else &apos; Return length of field, not content
254 vValue = lSize
255 End If
256 End If
257 End If
258 oValue.closeInput()
259 Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(piColIndex)
260 Case .DATE : vDateTime = poResultSet.getDate(piColIndex)
261 If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
262 Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
263 vValue = Null
264 Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(piColIndex)
265 Case .FLOAT : vValue = poResultSet.getFloat(piColIndex)
266 Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(piColIndex)
267 Case .BIGINT : vValue = poResultSet.getLong(piColIndex)
268 Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(piColIndex)
269 Case .SQLNULL : vValue = poResultSet.getNull(piColIndex)
270 Case .OBJECT, .OTHER, .STRUCT : vValue = Null
271 Case .REF : vValue = poResultSet.getRef(piColIndex)
272 Case .TINYINT : vValue = poResultSet.getShort(piColIndex)
273 Case .CHAR, .VARCHAR : vValue = poResultSet.getString(piColIndex)
274 Case .LONGVARCHAR, .CLOB
275 Set oValue = poResultSet.getCharacterStream(piColIndex)
276 If bNullable Then
277 If Not poResultSet.wasNull() Then
278 If Not _hasUNOMethod(oValue, &quot;getLength&quot;) Then &apos; When no recordset
279 lSize = cstMaxTextLength
280 Else
281 lSize = CLng(oValue.getLength())
282 End If
283 oValue.closeInput()
284 If lSize &lt;= cstMaxBinLength Then vValue = poResultSet.getString(piColIndex) Else vValue = &quot;&quot;
285 End If
286 Else
287 oValue.closeInput()
288 End If
289 Case .TIME : vDateTime = poResultSet.getTime(piColIndex)
290 If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)&apos;, vDateTime.HundredthSeconds)
291 Case .TIMESTAMP : vDateTime = poResultSet.getTimeStamp(piColIndex)
292 If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
293 + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)&apos;, vDateTime.HundredthSeconds)
294 Case Else
295 vValue = poResultSet.getString(piColIndex) &apos;GIVE STRING A TRY
296 If IsNumeric(vValue) Then vValue = Val(vValue) &apos;Required when type = &quot;&quot;, sometimes numeric fields are returned as strings (query/MSAccess)
297 End Select
298 If bNullable Then
299 If poResultSet.wasNull() Then vValue = Null
300 End If
301 End With
302
303 _GetResultSetColumnValue = vValue
304
305 End Function &apos; GetResultSetColumnValue V 1.5.0
306
307 REM -----------------------------------------------------------------------------------------------------------------------
308 Public Function _FinalProperty(psShortcut As String) As String
309 &apos; Return the final property of a shortcut
310
311 Const cstEXCLAMATION = &quot;!&quot;
312 Const cstDOT = &quot;.&quot;
313
314 Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
315 Dim sComponents() As String, sSubComponents() As String
316 _FinalProperty = &quot;&quot;
317 sComponents = Split(Trim(psShortcut), cstEXCLAMATION)
318 If UBound(sComponents) = 0 Then Exit Function
319 sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
320 Select Case UBound(sSubComponents)
321 Case 1
322 _FinalProperty = sSubComponents(1)
323 Case Else
324 Exit Function
325 End Select
326
327 End Function &apos; FinalProperty
328
329 REM -----------------------------------------------------------------------------------------------------------------------
330 Public Function _GetProductName(ByVal Optional psFlag As String) as String
331 &apos;Return OO product (&quot;PRODUCT&quot;) and version numbers (&quot;VERSION&quot;)
332 &apos;Derived from Tools library
333
334 Dim oProdNameAccess as Object
335 Dim sVersion as String
336 Dim sProdName as String
337 If IsMissing(psFlag) Then psFlag = &quot;ALL&quot;
338 oProdNameAccess = _GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
339 sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
340 sVersion = oProdNameAccess.getByName(&quot;ooSetupVersionAboutBox&quot;)
341 Select Case psFlag
342 Case &quot;ALL&quot; : _GetProductName = sProdName &amp; &quot; &quot; &amp; sVersion
343 Case &quot;PRODUCT&quot; : _GetProductName = sProdName
344 Case &quot;VERSION&quot; : _GetProductName = sVersion
345 End Select
346 End Function &apos; GetProductName V1.0.0
347
348 REM -----------------------------------------------------------------------------------------------------------------------
349 Public Function _GetRandomFileName(ByVal psName As String) As String
350 &apos; Return the full name of a random temporary file suffixed by psName
351
352 Dim sRandom As String
353 sRandom = Right(&quot;000000&quot; &amp; Int(999999 * Rnd), 6)
354 _GetRandomFileName = Utils._getTempDirectoryURL() &amp; &quot;/&quot; &amp; &quot;A2B_TEMP_&quot; &amp; psName &amp; &quot;_&quot; &amp; sRandom
355
356 End Function &apos; GetRandomFileName
357
358 REM -----------------------------------------------------------------------------------------------------------------------
359 Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant
360 &apos;Implement ConfigurationProvider service
361 &apos;Derived from Tools library
362
363 Dim oConfigProvider as Object
364 Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
365 oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
366 aNodePath(0).Name = &quot;nodepath&quot;
367 aNodePath(0).Value = sKeyName
368 If IsMissing(bForUpdate) Then bForUpdate = False
369 If bForUpdate Then
370 _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationUpdateAccess&quot;, aNodePath())
371 Else
372 _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
373 End If
374 End Function &apos; GetRegistryKeyContent V0.8.5
375
376 REM -----------------------------------------------------------------------------------------------------------------------
377 Public Function _getTempDirectoryURL() As String
378 &apos; Return the temporary directory defined in the OO Options (Paths)
379 Dim sDirectory As String, oSettings As Object, oPathSettings As Object
380
381 If _ErrorHandler() Then On Local Error Goto Error_Function
382
383 _getTempDirectoryURL = &quot;&quot;
384 oPathSettings = createUnoService( &quot;com.sun.star.util.PathSettings&quot; )
385 sDirectory = oPathSettings.GetPropertyValue( &quot;Temp&quot; )
386
387 _getTempDirectoryURL = sDirectory
388
389 Exit_Function:
390 Exit Function
391 Error_Function:
392 TraceError(&quot;ERROR&quot;, Err, &quot;_getTempDirectoryURL&quot;, Erl)
393 _getTempDirectoryURL = &quot;&quot;
394 Goto Exit_Function
395 End Function &apos; _getTempDirectoryURL V0.8.5
396
397 REM -----------------------------------------------------------------------------------------------------------------------
398 Public Function _getUNOTypeName(pvObject As Variant) As String
399 &apos; Return the symbolic name of the pvObject (UNO-object) type
400 &apos; Code-snippet from XRAY
401
402 Dim oService As Object, vClass as Variant
403 _getUNOTypeName = &quot;&quot;
404 On Local Error Resume Next
405 oService = CreateUnoService(&quot;com.sun.star.reflection.CoreReflection&quot;)
406 vClass = oService.getType(pvObject)
407 If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then
408 _getUNOTypeName = vClass.Name
409 End If
410 oService.Dispose()
411
412 End Function &apos; getUNOTypeName
413
414 REM -----------------------------------------------------------------------------------------------------------------------
415 Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean
416 &apos; Return true if pvObject has the (UNO) method psMethod
417 &apos; Code-snippet found in Bernard Marcelly&apos;s XRAY
418
419 Dim vInspect as Variant
420 _hasUNOMethod = False
421 On Local Error Resume Next
422 vInspect = _A2B_.Introspection.Inspect(pvObject)
423 _hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL)
424
425 End Function &apos; hasUNOMethod V0.8.0
426
427 REM -----------------------------------------------------------------------------------------------------------------------
428 Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean
429 &apos; Return true if pvObject has the (UNO) property psProperty
430 &apos; Code-snippet found in Bernard Marcelly&apos;s XRAY
431
432 Dim vInspect as Variant
433 _hasUNOProperty = False
434 On Local Error Resume Next
435 vInspect = _A2B_.Introspection.Inspect(pvObject)
436 _hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
437
438 End Function &apos; hasUNOProperty V0.8.0
439
440 REM -----------------------------------------------------------------------------------------------------------------------
441 Public Function _ImplementationName(pvObject As Variant) As String
442 &apos; Use getImplementationName method or _getUNOTypeName function
443
444 Dim sObjectType As String
445 On Local Error Resume Next
446 sObjectType = pvObject.getImplementationName()
447 If sObjectType = &quot;&quot; Then sObjectType = _getUNOTypeName(pvObject)
448
449 _ImplementationName = sObjectType
450
451 End Function &apos; ImplementationName
452
453 REM -----------------------------------------------------------------------------------------------------------------------
454 Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant
455 &apos; Return True if pvItem is present in the pvList array (case insensitive comparison)
456 &apos; Return the value in pvList if pvReturnValue = True
457
458 Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer
459 Dim iTop As Integer, iBottom As Integer, iFound As Integer
460 iItemVarType = VarType(pvItem)
461 If IsMissing(pvReturnValue) Then pvReturnValue = False
462 If iItemVarType = vbNull Or IsNull(pvList) Then
463 _InList = False
464 ElseIf Not IsArray(pvList) Then
465 If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList )
466 If Not pvReturnValue Then
467 _InList = bFound
468 Else
469 If bFound Then _InList = pvList Else _InList = False
470 End If
471 ElseIf UBound(pvList) &lt; LBound(pvList) Then &apos; Array not initialized
472 _InList = False
473 Else
474 bFound = False
475 _InList = False
476 iListVarType = VarType(pvList(LBound(pvList)))
477 If iListVarType = iItemVarType _
478 Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _
479 Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _
480 And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _
481 Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _
482 ) Then
483 If IsMissing(pbBinarySearch) Then pbBinarySearch = False
484 If Not pbBinarySearch Then &apos; Linear search
485 For i = LBound(pvList) To UBound(pvList)
486 If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) )
487 If bFound Then
488 iFound = i
489 Exit For
490 End If
491 Next i
492 Else &apos; Binary search =&gt; array must be sorted
493 iTop = UBound(pvList)
494 iBottom = lBound(pvList)
495 Do
496 iFound = (iTop + iBottom) / 2
497 If ( iItemVarType = vbString And UCase(pvItem) &gt; UCase(pvList(iFound)) ) Or ( iItemVarType &lt;&gt; vbString And pvItem &gt; pvList(iFound) ) Then
498 iBottom = iFound + 1
499 Else
500 iTop = iFound - 1
501 End If
502 If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) )
503 Loop Until ( bFound ) Or ( iBottom &gt; iTop )
504 End If
505 If bFound Then
506 If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound)
507 End If
508 End If
509 End If
510
511 Exit Function
512
513 End Function &apos; InList V1.1.0
514
515 REM -----------------------------------------------------------------------------------------------------------------------
516 Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String
517 &apos;Return type of property EVEN WHEN EMPTY ! (Used in date and time controls)
518
519 Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object
520 &apos; On Local Error Resume Next
521 _InspectPropertyType = &quot;&quot;
522 Set oInspect1 = CreateUnoService(&quot;com.sun.star.script.Invocation&quot;)
523 Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection
524 If Not IsNull(oInspect2) Then
525 Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
526 If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name
527 End If
528 Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing
529
530 End Function &apos; InspectPropertyType V1.0.0
531
532 REM -----------------------------------------------------------------------------------------------------------------------
533 Public Function _IsLeft(psString As String, psLeft As String) As Boolean
534 &apos; Return True if left part of psString = psLeft
535
536 Dim iLength As Integer
537 iLength = Len(psLeft)
538 _IsLeft = False
539 If Len(psString) &gt;= iLength Then
540 If Left(psString, iLength) = psLeft Then _IsLeft = True
541 End If
542
543 End Function
544
545 REM -----------------------------------------------------------------------------------------------------------------------
546 Public Function _IsBinaryType(ByVal lType As Long) As Boolean
547
548 With com.sun.star.sdbc.DataType
549 Select Case lType
550 Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
551 _IsBinaryType = True
552 Case Else
553 _IsBinaryType = False
554 End Select
555 End With
556
557 End Function &apos; IsBinaryType V1.6.0
558
559 REM -----------------------------------------------------------------------------------------------------------------------
560 Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean
561 &apos; Test pvObject: does it exist ?
562 &apos; is the _Type item = one of the proposed pvTypes ?
563 &apos; does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ?
564
565 Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant
566
567 If _ErrorHandler() Then On Local Error Goto Exit_False
568
569 _IsPseudo = False
570 bIsPseudo = False
571 vObject = pvObject &apos; To avoid &quot;Object variable not set&quot; error message
572 Select Case True
573 Case IsEmpty(vObject)
574 Case IsNull(vObject)
575 Case VarType(vObject) &lt;&gt; vbObject
576 Case Else
577 With vObject
578 Select Case True
579 Case IsEmpty(._Type)
580 Case IsNull(._Type)
581 Case ._Type = &quot;&quot;
582 Case Else
583 bIsPseudo = _InList(._Type, pvType)
584 If Not bIsPseudo Then &apos; If primary type did not succeed, give the subtype a chance
585 If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType)
586 End If
587 End Select
588 End With
589 End Select
590
591 If Not bIsPseudo Then Goto Exit_Function
592
593 Dim oDoc As Object, oForms As Variant
594
595 bPseudoExists = False
596 With vObject
597 Select Case ._Type
598 Case OBJFORM
599 If ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of form name
600 Set oDoc = _A2B_.CurrentDocument()
601 If oDoc.DbConnect = DBCONNECTFORM Then
602 bPseudoExists = True
603 Else
604 Set oForms = oDoc.Document.getFormDocuments()
605 bPseudoExists = ( oForms.HasByName(._Name) )
606 End If
607 End If
608 Case OBJDATABASE
609 If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection)
610 Case OBJDIALOG
611 If ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of dialog name
612 bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) )
613 End If
614 Case OBJCOLLECTION
615 bPseudoExists = True
616 Case OBJCONTROL
617 If Not IsNull(.ControlModel) And ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of control
618 Set oForms = .ControlModel.Parent
619 bPseudoExists = ( oForms.hasByName(._Name) )
620 End If
621 Case OBJSUBFORM
622 If Not IsNull(.DatabaseForm) And ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of subform
623 If .DatabaseForm.ImplementationName = &quot;com.sun.star.comp.forms.ODatabaseForm&quot; Then
624 Set oForms = .DatabaseForm.Parent
625 bPseudoExists = ( oForms.hasByName(._Name) )
626 End If
627 End If
628 Case OBJOPTIONGROUP
629 bPseudoExists = ( .Count &gt; 0 )
630 Case OBJCOMMANDBAR
631 bPseudoExists = ( Not IsNull(._Window) )
632 Case OBJCOMMANDBARCONTROL
633 bPseudoExists = ( Not IsNull(._ParentCommandBar) )
634 Case OBJEVENT
635 bPseudoExists = ( Not IsNull(._EventSource) )
636 Case OBJPROPERTY
637 bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; )
638 Case OBJTABLEDEF
639 bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Table) )
640 Case OBJQUERYDEF
641 bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Query) )
642 Case OBJRECORDSET
643 bPseudoExists = ( Not IsNull(.RowSet) )
644 Case OBJFIELD
645 bPseudoExists = ( ._Name &lt;&gt; &quot;&quot; And Not IsNull(.Column) )
646 Case OBJTEMPVAR
647 If ._Name &lt;&gt; &quot;&quot; Then &apos; Check validity of tempvar name
648 bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) )
649 End If
650 Case Else
651 End Select
652 End With
653
654 _IsPseudo = ( bIsPseudo And bPseudoExists )
655
656 Exit_Function:
657 Exit Function
658 Exit_False:
659 _IsPseudo = False
660 Goto Exit_Function
661 End Function &apos; IsPseudo V1.1.0
662
663 REM -----------------------------------------------------------------------------------------------------------------------
664 Private Function _IsScalar(ByVal pvArg As Variant, Byval pvType As Variant, ByVal Optional pvValid As Variant) As Boolean
665 &apos; Check type of pvArg and value in allowed pvValid list
666
667 _IsScalar = False
668
669 If IsArray(pvType) Then
670 If Not _InList(VarType(pvArg), pvType) Then Exit Function
671 ElseIf VarType(pvArg) &lt;&gt; pvType Then
672 If pvType = vbBoolean And VarType(pvArg) = vbLong Then
673 If pvArg &lt; -1 And pvArg &gt; 0 Then Exit Function &apos; Special boolean processing because the Not function returns a Long
674 Else
675 Exit Function
676 End If
677 End If
678 If Not IsMissing(pvValid) Then
679 If Not _InList(pvArg, pvValid) Then Exit Function
680 End If
681
682 _IsScalar = True
683
684 Exit_Function:
685 Exit Function
686 End Function &apos; IsScalar V0.7.5
687
688 REM -----------------------------------------------------------------------------------------------------------------------
689 Public Function _PCase(ByVal psString As String) As String
690 &apos; Return the proper case representation of argument
691
692 Dim vSubStrings() As Variant, i As Integer, iLen As Integer
693 vSubStrings = Split(psString, &quot; &quot;)
694 For i = 0 To UBound(vSubStrings)
695 iLen = Len(vSubStrings(i))
696 If iLen &gt; 1 Then
697 vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) &amp; LCase(Right(vSubStrings(i), iLen - 1))
698 ElseIf iLen = 1 Then
699 vSubStrings(i) = UCase(vSubStrings(i))
700 End If
701 Next i
702 _PCase = Join(vSubStrings, &quot; &quot;)
703
704 End Function &apos; PCase V0.9.0
705
706 REM -----------------------------------------------------------------------------------------------------------------------
707 Private Function _PercentEncode(ByVal psChar As String) As String
708 &apos; Percent encoding of single psChar character
709 &apos; https://en.wikipedia.org/wiki/UTF-8
710
711 Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
712 lChar = Asc(psChar)
713
714 Select Case lChar
715 Case 48 To 57, 65 To 90, 97 To 122 &apos; 0-9, A-Z, a-z
716 _PercentEncode = psChar
717 Case Asc(&quot;-&quot;), Asc(&quot;.&quot;), Asc(&quot;_&quot;), Asc(&quot;~&quot;)
718 _PercentEncode = psChar
719 Case Asc(&quot;!&quot;), Asc(&quot;$&quot;), Asc(&quot;&amp;&quot;), Asc(&quot;&apos;&quot;), Asc(&quot;(&quot;), Asc(&quot;)&quot;), Asc(&quot;*&quot;), Asc(&quot;+&quot;), Asc(&quot;,&quot;), Asc(&quot;;&quot;), Asc(&quot;=&quot;) &apos; Reserved characters used as delimitors in query strings
720 _PercentEncode = psChar
721 Case Asc(&quot; &quot;), Asc(&quot;%&quot;)
722 _PercentEncode = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(lChar), 2)
723 Case 0 To 127
724 _PercentEncode = psChar
725 Case 128 To 2047
726 sByte1 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar / 64) + 192), 2)
727 sByte2 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex((lChar Mod 64) + 128), 2)
728 _PercentEncode = sByte1 &amp; sByte2
729 Case 2048 To 65535
730 sByte1 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar / 4096) + 224), 2)
731 sByte2 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
732 sByte3 = &quot;%&quot; &amp; Right(&quot;00&quot; &amp; Hex((lChar Mod 64) + 128), 2)
733 _PercentEncode = sByte1 &amp; sByte2 &amp; sByte3
734 Case Else &apos; Not supported
735 _PercentEncode = psChar
736 End Select
737
738 Exit Function
739
740 End Function &apos; _PercentEncode V1.4.0
741
742 REM -----------------------------------------------------------------------------------------------------------------------
743 Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
744 &apos; Loads all lines of a text file into a variant array
745 &apos; Any error reduces output to an empty array
746 &apos; Input file name presumed in URL form
747
748 Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer
749 Const cstMaxLines = 16000 &apos; +/- the limit of array sizes in Basic
750 On Local Error GoTo Error_Function
751 vLines = Array()
752 _ReadFileIntoArray = Array()
753 If psFileName = &quot;&quot; Then Exit Function
754
755 iFile = FreeFile()
756 Open psFileName For Input Access Read Shared As #iFile
757 iCount1 = 0
758 Do While Not Eof(iFile) And iCount1 &lt; cstMaxLines
759 Line Input #iFile, sLine
760 iCount1 = iCount1 + 1
761 Loop
762 Close #iFile
763
764 ReDim vLines(0 To iCount1 - 1) &apos; Reading file twice preferred to ReDim Preserve for performance reasons
765 iFile = FreeFile()
766 Open psFileName For Input Access Read Shared As #iFile
767 iCount2 = 0
768 Do While Not Eof(iFile) And iCount2 &lt; iCount1
769 Line Input #iFile, vLines(iCount2)
770 iCount2 = iCount2 + 1
771 Loop
772 Close #iFile
773
774 Exit_Function:
775 _ReadFileIntoArray() = vLines()
776 Exit Function
777 Error_Function:
778 vLines = Array()
779 Resume Exit_Function
780 End Function &apos; _ReadFileIntoArray V1.4.0
781
782 REM -----------------------------------------------------------------------------------------------------------------------
783 Public Sub _ResetCalledSub(ByVal psSub As String)
784 &apos; Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
785 &apos; Used to trace routine in/outs and to clarify error messages
786 If IsEmpty(_A2B_) Then Call Application._RootInit() &apos; Only is Utils module recompiled
787 If _A2B_.CalledSub = psSub Then _A2B_.CalledSub = &quot;&quot;
788 If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel(&quot;Exiting&quot;) &amp; &quot; &quot; &amp; psSub &amp; &quot; ...&quot;, False)
789 End Sub &apos; ResetCalledSub
790
791 REM -----------------------------------------------------------------------------------------------------------------------
792 Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean
793 &apos; Execute a given script with pvArgs() array of arguments
794
795 On Local Error Goto Error_Function
796 _RunScript = False
797 If IsNull(ThisComponent) Then Goto Exit_Function
798
799 Dim oSCriptProvider As Object, oScript As Object, vResult As Variant
800
801 Set oScriptProvider = ThisComponent.ScriptProvider()
802 Set oScript = oScriptProvider.getScript(psScript)
803 If IsMissing(pvArgs()) Then pvArgs() = Array()
804 vResult = oScript.Invoke(pvArgs(), Array(), Array())
805 _RunScript = True
806
807 Exit_Function:
808 Exit Function
809 Error_Function:
810 _RunScript = False
811 Goto Exit_Function
812 End Function
813
814 REM -----------------------------------------------------------------------------------------------------------------------
815 Public Sub _SetCalledSub(ByVal psSub As String)
816 &apos; Called in top of each public function.
817 &apos; Used to trace routine in/outs and to clarify error messages
818 If IsEmpty(_A2B_) Then Call Application._RootInit() &apos; First use of Access2Base in current LibO/AOO session
819 If _A2B_.CalledSub = &quot;&quot; Then _A2B_.CalledSub = psSub
820 If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel(&quot;Entering&quot;) &amp; &quot; &quot; &amp; psSub &amp; &quot; ...&quot;, False)
821 End Sub &apos; SetCalledSub
822
823 REM -----------------------------------------------------------------------------------------------------------------------
824 Public Function _Surround(ByVal psName As String) As String
825 &apos; Return [Name] if Name contains spaces
826 &apos; Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots
827
828 Const cstSquareOpen = &quot;[&quot;
829 Const cstSquareClose = &quot;]&quot;
830 Const cstDot = &quot;.&quot;
831 Dim sName As String
832
833 If InStr(psName, &quot;.&quot;) &gt; 0 Then
834 sName = Join(Split(psName, cstDot), cstSquareClose &amp; cstDot &amp; cstSquareOpen)
835 _Surround = cstSquareOpen &amp; sName &amp; cstSquareClose
836 ElseIf InStr(psName, &quot; &quot;) &gt; 0 Then
837 _Surround = cstSquareOpen &amp; psName &amp; cstSquareClose
838 Else
839 _Surround = psName
840 End If
841
842 End Function &apos; Surround
843
844 REM -----------------------------------------------------------------------------------------------------------------------
845 Public Function _Trim(ByVal psString As String) As String
846 &apos; Remove leading and trailing spaces, remove surrounding square brackets
847 Const cstSquareOpen = &quot;[&quot;
848 Const cstSquareClose = &quot;]&quot;
849 Dim sTrim As String
850
851 sTrim = Trim(psString)
852 _Trim = sTrim
853 If Len(sTrim) &lt;= 2 Then Exit Function
854
855 If Left(sTrim, 1) = cstSquareOpen Then
856 If Right(sTrim, 1) = cstSquareClose Then
857 _Trim = Mid(sTrim, 2, Len(sTrim) - 2)
858 End If
859 End If
860 End Function &apos; Trim V0.9.0
861
862 REM -----------------------------------------------------------------------------------------------------------------------
863 Public Function _TrimArray(pvArray As Variant) As Variant
864 &apos; Remove empty strings from strings array
865
866 Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer
867 vTrim = Null
868 If Not IsArray(pvArray) Then
869 If Len(Trim(pvArray)) &gt; 0 Then vTrim = Array(pvArray) Else vTrim = Array()
870 ElseIf UBound(pvArray) &lt; LBound(pvArray) Then &apos; Array empty
871 vTrim = Array()
872 Else
873 iCount = 0
874 For i = LBound(pvArray) To UBound(pvArray)
875 If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1
876 Next i
877 If iCount = 0 Then
878 vTrim() = pvArray()
879 ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then &apos; Array empty or all blanks
880 vTrim() = Array()
881 Else
882 ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount)
883 j = 0
884 For i = LBound(pvArray) To UBound(pvArray)
885 If Len(Trim(pvArray(i))) &gt; 0 Then
886 vTrim(j) = pvArray(i)
887 j = j + 1
888 End If
889 Next i
890 End If
891 End If
892
893 _TrimArray() = vTrim()
894
895 End Function &apos; TrimArray V0.9.0
896
897 REM -----------------------------------------------------------------------------------------------------------------------
898 Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _
899 , poResultSet As Object _
900 , ByVal piColIndex As Integer _
901 , ByVal pvValue As Variant _
902 ) As Boolean
903 REM store the pvValue for the column specified by ColIndex
904 REM get type name from metadata
905
906 Dim iType As Integer, vDateTime As Variant, oValue As Object
907 Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String
908 Const cstMaxTextLength = 65535
909 Const cstMaxBinlength = 2 * 65535
910
911 On Local Error Goto 0 &apos; Disable error handler
912 _UpdateResultSetColumnValue = False
913 With com.sun.star.sdbc.DataType
914 iType = poResultSet.MetaData.getColumnType(piColIndex)
915 iValueType = VarType(pvValue)
916 sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex))
917 bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
918
919 If bNullable And IsNull(pvValue) Then
920 poResultSet.updateNull(piColIndex)
921 Else
922 Select Case iType
923 Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT
924 poResultSet.updateNull(piColIndex)
925 Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
926 poResultSet.updateBytes(piColIndex, pvValue)
927 Case .BIT, .BOOLEAN : poResultSet.updateBoolean(piColIndex, pvValue)
928 Case .DATE : vDateTime = CreateUnoStruct(&quot;com.sun.star.util.Date&quot;)
929 vDateTime.Year = Year(pvValue)
930 vDateTime.Month = Month(pvValue)
931 vDateTime.Day = Day(pvValue)
932 poResultSet.updateDate(piColIndex, vDateTime)
933 Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
934 Case .DOUBLE, .REAL : poResultSet.updateDouble(piColIndex, pvValue)
935 Case .FLOAT : poResultSet.updateFloat(piColIndex, pvValue)
936 Case .INTEGER, .SMALLINT : poResultSet.updateInt(piColIndex, pvValue)
937 Case .BIGINT : poResultSet.updateLong(piColIndex, pvValue)
938 Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
939 Case .TINYINT : poResultSet.updateShort(piColIndex, pvValue)
940 Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
941 If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, &quot;BINARY&quot;) &gt;0 Then &apos; Sqlite exception ... !
942 poResultSet.updateBytes(piColIndex, pvValue)
943 Else
944 poResultSet.updateString(piColIndex, pvValue)
945 End If
946 Case .TIME : vDateTime = CreateUnoStruct(&quot;com.sun.star.util.Time&quot;)
947 vDateTime.Hours = Hour(pvValue)
948 vDateTime.Minutes = Minute(pvValue)
949 vDateTime.Seconds = Second(pvValue)
950 &apos;vDateTime.HundredthSeconds = 0
951 poResultSet.updateTime(piColIndex, vDateTime)
952 Case .TIMESTAMP : vDateTime = CreateUnoStruct(&quot;com.sun.star.util.DateTime&quot;)
953 vDateTime.Year = Year(pvValue)
954 vDateTime.Month = Month(pvValue)
955 vDateTime.Day = Day(pvValue)
956 vDateTime.Hours = Hour(pvValue)
957 vDateTime.Minutes = Minute(pvValue)
958 vDateTime.Seconds = Second(pvValue)
959 &apos;vDateTime.HundredthSeconds = 0
960 poResultSet.updateTimestamp(piColIndex, vDateTime)
961 Case Else
962 If bNullable Then poResultSet.updateNull(piColIndex)
963 End Select
964 End If
965
966 End With
967
968 _UpdateResultSetColumnValue = True
969
970 End Function &apos; UpdateResultSetColumnValue V 1.6.0
971
972 REM -----------------------------------------------------------------------------------------------------------------------
973 Private Function _URLEncode(ByVal psToEncode As String) As String
974 &apos; http://www.w3schools.com/tags/ref_urlencode.asp
975 &apos; http://xkr.us/articles/javascript/encode-compare/
976 &apos; http://tools.ietf.org/html/rfc3986
977
978 Dim sEncoded As String, sChar As String
979 Dim lCurrentChar As Long, bQuestionMark As Boolean
980
981 sEncoded = &quot;&quot;
982 bQuestionMark = False
983 For lCurrentChar = 1 To Len(psToEncode)
984 sChar = Mid(psToEncode, lCurrentChar, 1)
985 Select Case sChar
986 Case &quot; &quot;, &quot;%&quot;
987 sEncoded = sEncoded &amp; _PercentEncode(sChar)
988 Case &quot;?&quot; &apos; Is it the first &quot;?&quot; ?
989 If bQuestionMark Then &apos; &quot;?&quot; introduces in a URL the arguments part
990 sEncoded = sEncoded &amp; _PercentEncode(sChar)
991 Else
992 sEncoded = sEncoded &amp; sChar
993 bQuestionMark = True
994 End If
995 Case &quot;\&quot;
996 If bQuestionMark Then
997 sEncoded = sEncoded &amp; _PercentEncode(sChar)
998 Else
999 sEncoded = sEncoded &amp; &quot;/&quot; &apos; If Windows file naming ...
1000 End If
1001 Case Else
1002 If bQuestionMark Then
1003 sEncoded = sEncoded &amp; _PercentEncode(sChar)
1004 Else
1005 sEncoded = sEncoded &amp; _UTF8Encode(sChar) &apos; Because IE does not support %encoding in first part of URL
1006 End If
1007 End Select
1008 Next lCurrentChar
1009
1010 _URLEncode = sEncoded
1011
1012 End Function &apos; _URLEncode V1.4.0
1013
1014 REM -----------------------------------------------------------------------------------------------------------------------
1015 Private Function _UTF8Encode(ByVal psChar As String) As String
1016 &apos; &amp;-encoding of single psChar character (e.g. &quot;é&quot; becomes &quot;&amp;eacute;&quot; or numeric equivalent
1017 &apos; http://www.w3schools.com/charsets/ref_html_utf8.asp
1018
1019 Select Case psChar
1020 Case &quot;&quot;&quot;&quot; : _UTF8Encode = &quot;&amp;quot;&quot;
1021 Case &quot;&amp;&quot; : _UTF8Encode = &quot;&amp;amp;&quot;
1022 Case &quot;&lt;&quot; : _UTF8Encode = &quot;&amp;lt;&quot;
1023 Case &quot;&gt;&quot; : _UTF8Encode = &quot;&amp;gt;&quot;
1024 Case &quot;&apos;&quot; : _UTF8Encode = &quot;&amp;apos;&quot;
1025 Case &quot;:&quot;, &quot;/&quot;, &quot;?&quot;, &quot;#&quot;, &quot;[&quot;, &quot;]&quot;, &quot;@&quot; &apos; Reserved characters
1026 _UTF8Encode = psChar
1027 Case Chr(13) : _UTF8Encode = &quot;&quot; &apos; Carriage return
1028 Case Chr(10) : _UTF8Encode = &quot;&lt;br&gt;&quot; &apos; Line Feed
1029 Case &lt; Chr(126) : _UTF8Encode = psChar
1030 Case &quot;€&quot; : _UTF8Encode = &quot;&amp;euro;&quot;
1031 Case Else : _UTF8Encode = &quot;&amp;#&quot; &amp; Asc(psChar) &amp; &quot;;&quot;
1032 End Select
1033
1034 Exit Function
1035
1036 End Function &apos; _UTF8Encode V1.4.0
1037
1038
1039 </script:module>
FREE OFFICE SUITE