?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
cURL: follow redirects
[LibreOffice.git] / wizards / source / access2base / Database.xba
blob63ad4e5a34313ab676412c47b6908e5960fb3a58
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="Database" 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 Compatible
9 Option ClassModule
10
11 Option Explicit
12
13 REM -----------------------------------------------------------------------------------------------------------------------
14 REM --- CLASS ROOT FIELDS ---
15 REM -----------------------------------------------------------------------------------------------------------------------
16
17 Private _Type As String &apos; Must be DATABASE
18 Private _This As Object &apos; Workaround for absence of This builtin function
19 Private _DbConnect As Integer &apos; DBCONNECTxxx constants
20 Private Title As String
21 Private Document As Object &apos; com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
22 Private Connection As Object &apos; com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection
23 Private URL As String
24 Private _ReadOnly As Boolean
25 Private MetaData As Object &apos; interface XDatabaseMetaData
26 Private _RDBMS As Integer &apos; DBMS constants
27 Private _ColumnTypes() As Variant &apos; Part of Metadata.GetTypeInfo()
28 Private _ColumnTypeNames() As Variant
29 Private _ColumnPrecisions() As Variant
30 Private _ColumnTypesReference() As Variant
31 Private _ColumnTypesAlias() As Variant &apos; To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods
32 Private _BinaryStream As Boolean &apos; False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes
33 Private Form As Object &apos; com.sun.star.form.XForm
34 Private FormName As String
35 Private RecordsetMax As Integer
36 Private RecordsetsColl As Object &apos; Collection of active recordsets
37
38 REM -----------------------------------------------------------------------------------------------------------------------
39 REM --- CONSTRUCTORS / DESTRUCTORS ---
40 REM -----------------------------------------------------------------------------------------------------------------------
41 Private Sub Class_Initialize()
42 _Type = OBJDATABASE
43 Set _This = Nothing
44 _DbConnect = 0
45 Title = &quot;&quot;
46 Set Document = Nothing
47 Set Connection = Nothing
48 URL = &quot;&quot;
49 _ReadOnly = False
50 Set MetaData = Nothing
51 _RDBMS = DBMS_UNKNOWN
52 _ColumnTypes = Array()
53 _ColumnTypeNames = Array()
54 _ColumnPrecisions = Array()
55 _ColumnTypesReference = Array()
56 _ColumnTypesAlias() = Array()
57 _BinaryStream = False
58 Set Form = Nothing
59 FormName = &quot;&quot;
60 RecordsetMax = 0
61 Set RecordsetsColl = New Collection
62 End Sub &apos; Constructor
63
64 REM -----------------------------------------------------------------------------------------------------------------------
65 Private Sub Class_Terminate()
66 On Local Error Resume Next
67 Call CloseAllRecordsets()
68 If _DbConnect &lt;&gt; DBCONNECTANY Then
69 If Not IsNull(Connection) Then
70 Connection.close()
71 Connection.dispose()
72 Set Connection = Nothing
73 End If
74 Else
75 mClose()
76 End If
77 Call Class_Initialize()
78 End Sub &apos; Destructor
79
80 REM -----------------------------------------------------------------------------------------------------------------------
81 Public Sub Dispose()
82 Call Class_Terminate()
83 End Sub &apos; Explicit destructor
84
85
86
87 REM -----------------------------------------------------------------------------------------------------------------------
88 REM --- CLASS GET/LET/SET PROPERTIES ---
89 REM -----------------------------------------------------------------------------------------------------------------------
90
91 Property Get Connect() As String
92 Connect = _PropertyGet(&quot;Connect&quot;)
93 End Property &apos; Connect (get)
94
95 REM -----------------------------------------------------------------------------------------------------------------------
96 Property Get Name() As String
97 Name = _PropertyGet(&quot;Name&quot;)
98 End Property &apos; Name (get)
99
100 REM -----------------------------------------------------------------------------------------------------------------------
101 Property Get ObjectType() As String
102 ObjectType = _PropertyGet(&quot;ObjectType&quot;)
103 End Property &apos; ObjectType (get)
104
105 REM -----------------------------------------------------------------------------------------------------------------------
106 Property Get Version() As String
107 Version = _PropertyGet(&quot;Version&quot;)
108 End Property &apos; Version (get)
109
110 REM -----------------------------------------------------------------------------------------------------------------------
111 REM --- CLASS METHODS ---
112 REM -----------------------------------------------------------------------------------------------------------------------
113
114 REM -----------------------------------------------------------------------------------------------------------------------
115 Public Function mClose() As Variant
116 &apos; Close the database
117
118 If _ErrorHandler() Then On Local Error Goto Error_Function
119 Const cstThisSub = &quot;Database.Close&quot;
120 Utils._SetCalledSub(cstThisSub)
121 mClose = False
122 If _DbConnect &lt;&gt; DBCONNECTANY Then Goto Error_NotApplicable
123
124 Connection.close()
125 Connection.dispose()
126 Set Connection = Nothing
127 mClose = True
128
129 Exit_Function:
130 Utils._ResetCalledSub(cstThisSub)
131 Exit Function
132 Error_NotApplicable:
133 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
134 Goto Exit_Function
135 Error_Function:
136 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
137 GoTo Exit_Function
138 End Function &apos; (m)Close
139
140 REM -----------------------------------------------------------------------------------------------------------------------
141 Public Sub CloseAllRecordsets()
142 &apos; Clean all recordsets for housekeeping
143
144 Dim sRecordsets() As String, i As Integer, oRecordset As Object
145 On Local Error Goto Exit_Sub
146
147 If IsNull(RecordsetsColl) Then Exit Sub
148 If RecordsetsColl.Count &lt; 1 Then Exit Sub
149 For i = 1 To RecordsetsColl.Count
150 Set oRecordset = RecordsetsColl.Item(i)
151 oRecordset.mClose(False) &apos; Do not remove entry in collection
152 Next i
153 Set RecordsetsColl = New Collection
154 RecordsetMax = 0
155
156 Exit_Sub:
157 Exit Sub
158 End Sub &apos; CloseAllRecordsets V0.9.5
159
160 REM -----------------------------------------------------------------------------------------------------------------------
161 Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
162 , ByVal Optional pvSql As Variant _
163 , ByVal Optional pvOption As Variant _
164 ) As Object
165 &apos;Return a (new) QueryDef object based on SQL statement
166 Const cstThisSub = &quot;Database.CreateQueryDef&quot;
167 Utils._SetCalledSub(cstThisSub)
168
169 Const cstNull = -1
170 Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String
171
172 If _ErrorHandler() Then On Local Error Goto Error_Function
173
174 Set CreateQueryDef = Nothing
175 If _DbConnect &lt;&gt; DBCONNECTBASE Then Goto Error_NotApplicable
176 If IsMissing(pvQueryName) Then Call _TraceArguments()
177 If IsMissing(pvSql) Then Call _TraceArguments()
178 If IsMissing(pvOption) Then pvOption = cstNull
179
180 If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
181 If pvQueryName = &quot;&quot; Then Call _TraceArguments()
182 If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
183 If pvSql = &quot;&quot; Then Call _TraceArguments()
184 If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
185
186 If _ReadOnly Then Goto Error_NoUpdate
187
188 Set oQuery = CreateUnoService(&quot;com.sun.star.sdb.QueryDefinition&quot;)
189 oQuery.rename(pvQueryName)
190 oQuery.Command = _ReplaceSquareBrackets(pvSql)
191 oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
192
193 Set oQueries = Document.DataSource.getQueryDefinitions()
194 With oQueries
195 For i = 0 To .getCount() - 1
196 sQueryName = .getByIndex(i).Name
197 If UCase(sQueryName) = UCase(pvQueryName) Then
198 TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
199 .removeByName(sQueryName)
200 Exit For
201 End If
202 Next i
203 .insertByName(pvQueryName, oQuery)
204 End With
205 Set CreateQueryDef = QueryDefs(pvQueryName)
206
207 Exit_Function:
208 Utils._ResetCalledSub(cstThisSub)
209 Exit Function
210 Error_NotApplicable:
211 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
212 Goto Exit_Function
213 Error_NoUpdate:
214 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
215 Goto Exit_Function
216 Error_Function:
217 TraceError(TRACEABORT, Err, cstThisSub, Erl)
218 GoTo Exit_Function
219 End Function &apos; CreateQueryDef V1.1.0
220
221 REM -----------------------------------------------------------------------------------------------------------------------
222 Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
223 &apos;Return a (new/empty) TableDef object
224 Const cstThisSub = &quot;Database.CreateTableDef&quot;
225 Utils._SetCalledSub(cstThisSub)
226
227 Dim oTable As Object, oTables As Object, sTables() As String
228 Dim i As Integer, sTableName As String, oNewTable As Object
229 Dim vNameComponents() As Variant, iNames As Integer
230
231 If _ErrorHandler() Then On Local Error Goto Error_Function
232
233 Set CreateTableDef = Nothing
234 If _DbConnect &lt;&gt; DBCONNECTBASE Then Goto Error_NotApplicable
235 If IsMissing(pvTableName) Then Call _TraceArguments()
236
237 If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
238 If pvTableName = &quot;&quot; Then Call _TraceArguments()
239
240 If _ReadOnly Then Goto Error_NoUpdate
241
242 Set oTables = Connection.getTables
243 With oTables
244 sTables = .ElementNames()
245 &apos; Check existence of object and find its exact (case-sensitive) name
246 For i = 0 To UBound(sTables)
247 If UCase(pvTableName) = UCase(sTables(i)) Then
248 sTableName = sTables(i)
249 TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
250 .dropByName(sTableName)
251 Exit For
252 End If
253 Next i
254 Set oNewTable = New DataDef
255 oNewTable._Type = OBJTABLEDEF
256 oNewTable._Name = pvTableName
257 vNameComponents = Split(pvTableName, &quot;.&quot;)
258 iNames = UBound(vNameComponents)
259 If iNames &gt;= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = &quot;&quot;
260 If iNames &gt;= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = &quot;&quot;
261 oNewtable.TableName = vNameComponents(iNames)
262 Set oNewTable._ParentDatabase = _This
263 Set oNewTable.TableDescriptor = .createDataDescriptor()
264 oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
265 oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
266 oNewTable.TableDescriptor.Name = oNewTable.TableName
267 oNewTable.TableDescriptor.Type = &quot;TABLE&quot;
268 End With
269
270 Set CreateTabledef = oNewTable
271
272 Exit_Function:
273 Utils._ResetCalledSub(cstThisSub)
274 Exit Function
275 Error_NotApplicable:
276 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
277 Goto Exit_Function
278 Error_NoUpdate:
279 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
280 Goto Exit_Function
281 Error_Function:
282 TraceError(TRACEABORT, Err, cstThisSub, Erl)
283 GoTo Exit_Function
284 End Function &apos; CreateTableDef V1.1.0
285
286 REM -----------------------------------------------------------------------------------------------------------------------
287 Public Function DAvg( _
288 ByVal Optional psExpr As String _
289 , ByVal Optional psDomain As String _
290 , ByVal Optional pvCriteria As Variant _
291 ) As Variant
292 &apos; Return average of scope
293 Const cstThisSub = &quot;Database.DAvg&quot;
294 Utils._SetCalledSub(cstThisSub)
295 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
296 DAvg = _DFunction(&quot;AVG&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
297 Utils._ResetCalledSub(cstThisSub)
298 End Function &apos; DAvg
299
300 REM -----------------------------------------------------------------------------------------------------------------------
301 Public Function DCount( _
302 ByVal Optional psExpr As String _
303 , ByVal Optional psDomain As String _
304 , ByVal Optional pvCriteria As Variant _
305 ) As Variant
306 &apos; Return # of occurrences of scope
307 Const cstThisSub = &quot;Database.DCount&quot;
308 Utils._SetCalledSub(cstThisSub)
309 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
310 DCount = _DFunction(&quot;COUNT&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
311 Utils._ResetCalledSub(cstThisSub)
312 End Function &apos; DCount
313
314 REM -----------------------------------------------------------------------------------------------------------------------
315 Public Function DLookup( _
316 ByVal Optional psExpr As String _
317 , ByVal Optional psDomain As String _
318 , ByVal Optional pvCriteria As Variant _
319 , ByVal Optional pvOrderClause As Variant _
320 ) As Variant
321
322 &apos; Return a value within a table
323 &apos;Arguments: psExpr: an SQL expression
324 &apos; psDomain: a table- or queryname
325 &apos; pvCriteria: an optional WHERE clause
326 &apos; pcOrderClause: an optional order clause incl. &quot;DESC&quot; if relevant
327 &apos;Return: Value of the psExpr if found, else Null.
328 &apos;Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
329 &apos;Examples:
330 &apos; 1. To find the last value, include DESC in the OrderClause, e.g.:
331 &apos; DLookup(&quot;[Surname] &amp; [FirstName]&quot;, &quot;tblClient&quot;, , &quot;ClientID DESC&quot;)
332 &apos; 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
333 &apos; DLookup(&quot;ClientID&quot;, &quot;tblClient&quot;, &quot;Surname Is Not Null&quot; , &quot;Surname&quot;)
334
335 Const cstThisSub = &quot;Database.DLookup&quot;
336 Utils._SetCalledSub(cstThisSub)
337 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
338 DLookup = _DFunction(&quot;&quot;, psExpr, psDomain _
339 , Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria) _
340 , Iif(IsMissing(pvOrderClause), &quot;&quot;, pvOrderClause) _
341 )
342 Utils._ResetCalledSub(cstThisSub)
343 End Function &apos; DLookup
344
345 REM -----------------------------------------------------------------------------------------------------------------------
346 Public Function DMax( _
347 ByVal Optional psExpr As String _
348 , ByVal Optional psDomain As String _
349 , ByVal Optional pvCriteria As Variant _
350 ) As Variant
351 &apos; Return maximum of scope
352 Const cstThisSub = &quot;Database.DMax&quot;
353 Utils._SetCalledSub(cstThisSub)
354 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
355 DMax = _DFunction(&quot;MAX&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
356 Utils._ResetCalledSub(cstThisSub)
357 End Function &apos; DMax
358
359 REM -----------------------------------------------------------------------------------------------------------------------
360 Public Function DMin( _
361 ByVal Optional psExpr As String _
362 , ByVal Optional psDomain As String _
363 , ByVal Optional pvCriteria As Variant _
364 ) As Variant
365 &apos; Return minimum of scope
366 Const cstThisSub = &quot;Database.DMin&quot;
367 Utils._SetCalledSub(cstThisSub)
368 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
369 DMin = _DFunction(&quot;MIN&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
370 Utils._ResetCalledSub(cstThisSub)
371 End Function &apos; DMin
372
373 REM -----------------------------------------------------------------------------------------------------------------------
374 Public Function DStDev( _
375 ByVal Optional psExpr As String _
376 , ByVal Optional psDomain As String _
377 , ByVal Optional pvCriteria As Variant _
378 ) As Variant
379 &apos; Return standard deviation of scope
380 Const cstThisSub = &quot;Database.DStDev&quot;
381 Utils._SetCalledSub(cstThisSub)
382 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
383 DStDev = _DFunction(&quot;STDDEV_SAMP&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;) &apos; STDDEV not STDEV !
384 Utils._ResetCalledSub(cstThisSub)
385 End Function &apos; DStDev
386
387 REM -----------------------------------------------------------------------------------------------------------------------
388 Public Function DStDevP( _
389 ByVal Optional psExpr As String _
390 , ByVal Optional psDomain As String _
391 , ByVal Optional pvCriteria As Variant _
392 ) As Variant
393 &apos; Return standard deviation of scope
394 Const cstThisSub = &quot;Database.DStDevP&quot;
395 Utils._SetCalledSub(cstThisSub)
396 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
397 DStDevP = _DFunction(&quot;STDDEV_POP&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;) &apos; STDDEV not STDEV !
398 Utils._ResetCalledSub(cstThisSub)
399 End Function &apos; DStDevP
400
401 REM -----------------------------------------------------------------------------------------------------------------------
402 Public Function DSum( _
403 ByVal Optional psExpr As String _
404 , ByVal Optional psDomain As String _
405 , ByVal Optional pvCriteria As Variant _
406 ) As Variant
407 &apos; Return sum of scope
408 Const cstThisSub = &quot;Database.DSum&quot;
409 Utils._SetCalledSub(cstThisSub)
410 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
411 DSum = _DFunction(&quot;SUM&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
412 Utils._ResetCalledSub(cstThisSub)
413 End Function &apos; DSum
414
415 REM -----------------------------------------------------------------------------------------------------------------------
416 Public Function DVar( _
417 ByVal Optional psExpr As String _
418 , ByVal Optional psDomain As String _
419 , ByVal Optional pvCriteria As Variant _
420 ) As Variant
421 &apos; Return variance of scope
422 Const cstThisSub = &quot;Database.DVar&quot;
423 Utils._SetCalledSub(cstThisSub)
424 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
425 DVar = _DFunction(&quot;VAR_SAMP&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
426 Utils._ResetCalledSub(cstThisSub)
427 End Function &apos; DVar
428
429 REM -----------------------------------------------------------------------------------------------------------------------
430 Public Function DVarP( _
431 ByVal Optional psExpr As String _
432 , ByVal Optional psDomain As String _
433 , ByVal Optional pvCriteria As Variant _
434 ) As Variant
435 &apos; Return variance of scope
436 Const cstThisSub = &quot;Database.DVarP&quot;
437 Utils._SetCalledSub(cstThisSub)
438 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
439 DVarP = _DFunction(&quot;VAR_POP&quot;, psExpr, psDomain, Iif(IsMissing(pvCriteria), &quot;&quot;, pvCriteria), &quot;&quot;)
440 Utils._ResetCalledSub(cstThisSub)
441 End Function &apos; DVarP
442
443 REM -----------------------------------------------------------------------------------------------------------------------
444 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
445 &apos; Return property value of psProperty property name
446
447 Utils._SetCalledSub(&quot;Database.getProperty&quot;)
448 If IsMissing(pvProperty) Then Call _TraceArguments()
449 getProperty = _PropertyGet(pvProperty)
450 Utils._ResetCalledSub(&quot;Database.getProperty&quot;)
451
452 End Function &apos; getProperty
453
454 REM -----------------------------------------------------------------------------------------------------------------------
455 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
456 &apos; Return True if object has a valid property called pvProperty (case-insensitive comparison !)
457
458 If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
459 Exit Function
460
461 End Function &apos; hasProperty
462
463 REM -----------------------------------------------------------------------------------------------------------------------
464 Public Function OpenRecordset(ByVal Optional pvSource As Variant _
465 , ByVal Optional pvType As Variant _
466 , ByVal Optional pvOptions As Variant _
467 , ByVal Optional pvLockEdit As Variant _
468 ) As Object
469 &apos;Return a Recordset object based on Source (= SQL, table or query name)
470
471 Const cstThisSub = &quot;Database.OpenRecordset&quot;
472 Utils._SetCalledSub(cstThisSub)
473 Const cstNull = -1
474
475 Dim lCommandType As Long, sCommand As String, oObject As Object
476 Dim sSource As String, i As Integer, iCount As Integer
477 Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object
478
479 If _ErrorHandler() Then On Local Error Goto Error_Function
480 Set oObject = Nothing
481 If IsMissing(pvSource) Then Call _TraceArguments()
482 If pvSource = &quot;&quot; Then Call _TraceArguments()
483 If IsMissing(pvType) Then
484 pvType = cstNull
485 Else
486 If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), dbOpenForwardOnly) Then Goto Exit_Function
487 End If
488 If IsMissing(pvOptions) Then
489 pvOptions = cstNull
490 Else
491 If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
492 End If
493 If IsMissing(pvLockEdit) Then
494 pvLockEdit = cstNull
495 Else
496 If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), dbReadOnly) Then Goto Exit_Function
497 End If
498
499 sSource = Split(UCase(Trim(pvSource)), &quot; &quot;)(0)
500 Select Case True
501 Case sSource = &quot;SELECT&quot;
502 lCommandType = com.sun.star.sdb.CommandType.COMMAND
503 sCommand = _ReplaceSquareBrackets(pvSource)
504 Case Else
505 sSource = UCase(Trim(pvSource))
506 REM Explore tables
507 Set oTables = Connection.getTables
508 sObjects = oTables.ElementNames()
509 bFound = False
510 For i = 0 To UBound(sObjects)
511 If sSource = UCase(sObjects(i)) Then
512 sCommand = sObjects(i)
513 bFound = True
514 Exit For
515 End If
516 Next i
517 If bFound Then
518 lCommandType = com.sun.star.sdb.CommandType.TABLE
519 Else
520 REM Explore queries
521 Set oQueries = Connection.getQueries
522 sObjects = oQueries.ElementNames()
523 For i = 0 To UBound(sObjects)
524 If sSource = UCase(sObjects(i)) Then
525 sCommand = sObjects(i)
526 bFound = True
527 Exit For
528 End If
529 Next i
530 If Not bFound Then Goto Trace_NotFound
531 lCommandType = com.sun.star.sdb.CommandType.QUERY
532 End If
533 End Select
534
535 Set oObject = New Recordset
536 With oObject
537 ._CommandType = lCommandType
538 ._Command = sCommand
539 ._ParentName = Title
540 ._ParentType = _Type
541 ._ForwardOnly = ( pvType = dbOpenForwardOnly )
542 ._PassThrough = ( pvOptions = dbSQLPassThrough )
543 ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
544 Set ._This = oObject
545 Set ._ParentDatabase = _This
546 Call ._Initialize()
547 RecordsetMax = RecordsetMax + 1
548 ._Name = Format(RecordsetMax, &quot;0000000&quot;)
549 RecordsetsColl.Add(oObject, UCase(._Name))
550 End With
551
552 If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() &apos; Do nothing if resultset empty
553
554 Exit_Function:
555 Set OpenRecordset = oObject
556 Set oObject = Nothing
557 Utils._ResetCalledSub(cstThisSub)
558 Exit Function
559 Error_Function:
560 TraceError(TRACEABORT, Err, cstThisSub, Erl)
561 GoTo Exit_Function
562 Trace_NotFound:
563 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;TABLE&quot;) &amp; &quot;/&quot; &amp; _GetLabel(&quot;QUERY&quot;), pvSource))
564 Goto Exit_Function
565 End Function &apos; OpenRecordset V1.1.0
566
567 REM -----------------------------------------------------------------------------------------------------------------------
568 Public Function OpenSQL(Optional ByVal pvSQL As Variant _
569 , Optional ByVal pvOption As Variant _
570 ) As Boolean
571 &apos; Return True if the execution of the SQL statement was successful
572 &apos; SQL must contain a SELECT query
573 &apos; pvOption can force pass through mode
574
575 If _ErrorHandler() Then On Local Error Goto Error_Function
576
577 Const cstThisSub = &quot;Database.OpenSQL&quot;
578 Utils._SetCalledSub(cstThisSub)
579
580 OpenSQL = False
581 If IsMissing(pvSQL) Then Call _TraceArguments()
582 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
583 Const cstNull = -1
584 If IsMissing(pvOption) Then
585 pvOption = cstNull
586 Else
587 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function
588 End If
589 If _DbConnect &lt;&gt; DBCONNECTBASE And _DbConnect &lt;&gt; DBCONNECTFORM Then Goto Error_NotApplicable
590
591 Dim oURL As New com.sun.star.util.URL, oDispatch As Object
592 Dim vArgs(8) as New com.sun.star.beans.PropertyValue
593
594 oURL.Complete = &quot;.component:DB/DataSourceBrowser&quot;
595 oDispatch = StarDesktop.queryDispatch(oURL, &quot;_Blank&quot;, 8)
596
597 vArgs(0).Name = &quot;ActiveConnection&quot; : vArgs(0).Value = Connection
598 vArgs(1).Name = &quot;CommandType&quot; : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND
599 vArgs(2).Name = &quot;Command&quot; : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL)
600 vArgs(3).Name = &quot;ShowMenu&quot; : vArgs(3).Value = True
601 vArgs(4).Name = &quot;ShowTreeView&quot; : vArgs(4).Value = False
602 vArgs(5).Name = &quot;ShowTreeViewButton&quot; : vArgs(5).Value = False
603 vArgs(6).Name = &quot;Filter&quot; : vArgs(6).Value = &quot;&quot;
604 vArgs(7).Name = &quot;ApplyFilter&quot; : vArgs(7).Value = False
605 vArgs(8).Name = &quot;EscapeProcessing&quot; : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))
606
607 oDispatch.dispatch(oURL, vArgs)
608 OpenSQL = True
609
610 Exit_Function:
611 Exit Function
612 Error_Function:
613 TraceError(TRACEABORT, Err, &quot;OpenSQL&quot;, Erl)
614 GoTo Exit_Function
615 SQL_Error:
616 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
617 Goto Exit_Function
618 Error_NotApplicable:
619 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
620 Goto Exit_Function
621 End Function &apos; OpenSQL V1.1.0
622
623 REM -----------------------------------------------------------------------------------------------------------------------
624 Public Function OutputTo(ByVal pvObjectType As Variant _
625 , ByVal Optional pvObjectName As Variant _
626 , ByVal Optional pvOutputFormat As Variant _
627 , ByVal Optional pvOutputFile As Variant _
628 , ByVal Optional pvAutoStart As Variant _
629 , ByVal Optional pvTemplateFile As Variant _
630 , ByVal Optional pvEncoding As Variant _
631 , ByVal Optional pvQuality As Variant _
632 , ByRef Optional pvHeaders As Variant _
633 , ByRef Optional pvData As Variant _
634 ) As Boolean
635 &apos;Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries
636 &apos;pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray
637
638 If _ErrorHandler() Then On Local Error Goto Error_Function
639 Const cstThisSub = &quot;Database.OutputTo&quot;
640 Utils._SetCalledSub(cstThisSub)
641
642 OutputTo = False
643
644 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function
645 If IsMissing(pvObjectName) Then Call _TraceArguments()
646 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
647 If IsMissing(pvOutputFormat) Then pvOutputFormat = &quot;&quot;
648 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
649 If pvOutputFormat &lt;&gt; &quot;&quot; Then
650 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
651 UCase(acFormatHTML), &quot;HTML&quot; _
652 , UCase(acFormatODS), &quot;ODS&quot; _
653 , UCase(acFormatXLS), &quot;XLS&quot; _
654 , UCase(acFormatXLSX), &quot;XLSX&quot; _
655 , UCase(acFormatTXT), &quot;TXT&quot;, &quot;CSV&quot; _
656 , &quot;&quot;)) _
657 Then Goto Exit_Function &apos; A 2nd time to allow case unsensitivity
658 End If
659 If IsMissing(pvOutputFile) Then pvOutputFile = &quot;&quot;
660 If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
661 If IsMissing(pvAutoStart) Then pvAutoStart = False
662 If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
663 If IsMissing(pvTemplateFile) Then pvTemplateFile = &quot;&quot;
664 If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
665 If IsMissing(pvEncoding) Then pvEncoding = 0
666 If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
667 If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
668 If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
669 If pvObjectType = acOutputArray Then
670 If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments()
671 pvOutputFormat = &quot;HTML&quot;
672 End If
673
674 Dim sOutputFile As String, oTable As Object
675 Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String
676
677 If pvObjectType = acOutputArray Then
678 Set oTable = Nothing
679 Else
680 &apos;Find applicable table or query
681 If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True)
682 If IsNull(oTable) Then Goto Error_NotFound
683 End If
684
685 &apos;Determine format and parameters
686 If pvOutputFormat = &quot;&quot; Then
687 sOutputFormat = _PromptFormat(Array(&quot;HTML&quot;, &quot;ODS&quot;, &quot;XLS&quot;, &quot;XLSX&quot;, &quot;TXT&quot;)) &apos; Prompt user for format
688 If sOutputFormat = &quot;&quot; Then Goto Exit_Function
689 Else
690 sOutputFormat = UCase(pvOutputFormat)
691 End If
692
693 &apos;Determine output file
694 If pvOutputFile = &quot;&quot; Then &apos; Prompt file picker to user
695 Select Case sOutputFormat
696 Case UCase(acFormatHTML), &quot;HTML&quot; : sSuffix = &quot;html&quot;
697 Case UCase(acFormatODS), &quot;ODS&quot; : sSuffix = &quot;ods&quot;
698 Case UCase(acFormatXLS), &quot;XLS&quot; : sSuffix = &quot;xls&quot;
699 Case UCase(acFormatXLSX), &quot;XLSX&quot; : sSuffix = &quot;xlsx&quot;
700 Case UCase(acFormatTXT), &quot;TXT&quot;, &quot;CSV&quot; : sSuffix = &quot;txt&quot;
701 End Select
702 sOutputFile = _PromptFilePicker(sSuffix)
703 If sOutputFile = &quot;&quot; Then Goto Exit_Function
704 Else
705 sOutputFile = pvOutputFile
706 End If
707 sOutputFile = ConvertToURL(sOutputFile)
708
709 &apos;Create file
710 Select Case sOutputFormat
711 Case UCase(acFormatHTML), &quot;HTML&quot;
712 If pvObjectType = acOutputArray Then
713 bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData)
714 Else
715 bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile)
716 End If
717 Case UCase(acFormatODS), &quot;ODS&quot;
718 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS)
719 Case UCase(acFormatXLS), &quot;XLS&quot;
720 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS)
721 Case UCase(acFormatXLS), &quot;XLSX&quot;
722 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX)
723 Case UCase(acFormatTXT), &quot;TXT&quot;, &quot;CSV&quot;
724 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding)
725 End Select
726
727 &apos;Launch application, if requested
728 If bOutput Then
729 If pvAutoStart Then Call _ShellExecute(sOutputFile)
730 Else
731 GoTo Error_File
732 End If
733
734 OutputTo = True
735
736 Exit_Function:
737 If Not IsNull(oTable) Then
738 oTable.Dispose()
739 Set oTable = Nothing
740 End If
741 Utils._ResetCalledSub(cstThisSub)
742 Exit Function
743 Error_NotFound:
744 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;OBJECT&quot;), pvObjectName))
745 Goto Exit_Function
746 Error_Function:
747 TraceError(TRACEABORT, Err, cstThisSub, Erl)
748 GoTo Exit_Function
749 Error_File:
750 TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
751 GoTo Exit_Function
752 End Function &apos; OutputTo V1.4.0
753
754 REM -----------------------------------------------------------------------------------------------------------------------
755 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
756 &apos; Return
757 &apos; a Collection object if pvIndex absent
758 &apos; a Property object otherwise
759
760 Utils._SetCalledSub(&quot;Database.Properties&quot;)
761 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
762 vPropertiesList = _PropertiesList()
763 sObject = Utils._PCase(_Type)
764 If IsMissing(pvIndex) Then
765 vProperty = PropertiesGet._Properties(sObject, &quot;&quot;, vPropertiesList)
766 Else
767 vProperty = PropertiesGet._Properties(sObject, &quot;&quot;, vPropertiesList, pvIndex)
768 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
769 End If
770 Set vProperty._ParentDatabase = _This
771
772 Exit_Function:
773 Set Properties = vProperty
774 Utils._ResetCalledSub(&quot;Database.Properties&quot;)
775 Exit Function
776 End Function &apos; Properties
777
778 REM -----------------------------------------------------------------------------------------------------------------------
779 Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
780 &apos; Collect all Queries in the database
781 &apos; pbCheck unpublished
782
783 If _ErrorHandler() Then On Local Error Goto Error_Function
784 Utils._SetCalledSub(&quot;Database.QueryDefs&quot;)
785 If IsMissing(pbCheck) Then pbCheck = False
786
787 Dim sObjects() As String, sObjectName As String, oObject As Object
788 Dim i As Integer, bFound As Boolean, oQueries As Object
789 Set oObject = Nothing
790 If Not IsMissing(pvIndex) Then
791 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
792 End If
793
794 Set oQueries = Connection.getQueries
795 sObjects = oQueries.ElementNames()
796 Select Case True
797 Case IsMissing(pvIndex)
798 Set oObject = New Collect
799 oObject._CollType = COLLQUERYDEFS
800 oObject._ParentType = OBJDATABASE
801 oObject._ParentName = &quot;&quot;
802 Set oObject._ParentDatabase = _This
803 oObject._Count = UBound(sObjects) + 1
804 Goto Exit_Function
805 Case VarType(pvIndex) = vbString
806 bFound = False
807 &apos; Check existence of object and find its exact (case-sensitive) name
808 For i = 0 To UBound(sObjects)
809 If UCase(pvIndex) = UCase(sObjects(i)) Then
810 sObjectName = sObjects(i)
811 bFound = True
812 Exit For
813 End If
814 Next i
815 If Not bFound Then Goto Trace_NotFound
816 Case Else &apos; pvIndex is numeric
817 If pvIndex &lt; 0 Or pvIndex &gt; UBound(sObjects) Then Goto Trace_IndexError
818 sObjectName = sObjects(pvIndex)
819 End Select
820
821 Set oObject = New DataDef
822 oObject._Type = OBJQUERYDEF
823 oObject._Name = sObjectName
824 Set oObject._ParentDatabase = _This
825 oObject._readOnly = _ReadOnly
826 Set oObject.Query = oQueries.getByName(sObjectName)
827
828 Exit_Function:
829 Set QueryDefs = oObject
830 Set oObject = Nothing
831 Utils._ResetCalledSub(&quot;Database.QueryDefs&quot;)
832 Exit Function
833 Error_Function:
834 TraceError(TRACEABORT, Err, &quot;Database.QueryDefs&quot;, Erl)
835 GoTo Exit_Function
836 Trace_NotFound:
837 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;QUERY&quot;), pvIndex))
838 Goto Exit_Function
839 Trace_IndexError:
840 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
841 Goto Exit_Function
842 End Function &apos; QueryDefs V1.1.0
843
844 REM -----------------------------------------------------------------------------------------------------------------------
845 Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
846 &apos; Collect all active recordsets
847
848 If _ErrorHandler() Then On Local Error Goto Error_Function
849 Utils._SetCalledSub(&quot;Database.Recordsets&quot;)
850
851 Set Recordsets = Nothing
852 If Not IsMissing(pvIndex) Then
853 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
854 End If
855
856 Dim sObjects() As String, sObjectName As String, oObject As Object
857 Dim i As Integer, bFound As Boolean, oTables As Object
858
859 Select Case True
860 Case IsMissing(pvIndex)
861 Set oObject = New Collect
862 oObject._CollType = COLLRECORDSETS
863 oObject._ParentType = OBJDATABASE
864 oObject._ParentName = &quot;&quot;
865 Set oObject._ParentDatabase = _This
866 oObject._Count = RecordsetsColl.Count
867 Case VarType(pvIndex) = vbString
868 bFound = _hasRecordset(pvIndex)
869 If Not bFound Then Goto Trace_NotFound
870 Set oObject = RecordsetsColl.Item(pvIndex)
871 Case Else &apos; pvIndex is numeric
872 If pvIndex &lt; 0 Or pvIndex &gt;= RecordsetsColl.Count Then Goto Trace_IndexError
873 Set oObject = RecordsetsColl.Item(pvIndex + 1) &apos; Collection members are numbered 1 ... Count
874 End Select
875
876 Exit_Function:
877 Set Recordsets = oObject
878 Set oObject = Nothing
879 Utils._ResetCalledSub(&quot;Database.Recordsets&quot;)
880 Exit Function
881 Error_Function:
882 TraceError(TRACEABORT, Err, &quot;Database.Recordsets&quot;, Erl)
883 GoTo Exit_Function
884 Trace_NotFound:
885 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;RECORDSET&quot;), pvIndex))
886 Goto Exit_Function
887 Trace_IndexError:
888 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
889 Goto Exit_Function
890 End Function &apos; Recordsets V0.9.5
891
892 REM -----------------------------------------------------------------------------------------------------------------------
893 Public Function RunSQL(Optional ByVal pvSQL As Variant _
894 , Optional ByVal pvOption As Variant _
895 ) As Boolean
896 &apos; Return True if the execution of the SQL statement was successful
897 &apos; SQL must contain an ACTION query
898
899 If _ErrorHandler() Then On Local Error Goto Error_Function
900
901 Utils._SetCalledSub(&quot;RunSQL&quot;)
902
903 RunSQL = False
904 If IsMissing(pvSQL) Then Call _TraceArguments()
905 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
906 Const cstNull = -1
907 If IsMissing(pvOption) Then
908 pvOption = cstNull
909 Else
910 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
911 End If
912
913 Dim oStatement As Object, vResult As Variant
914 Set oStatement = Connection.createStatement()
915 oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
916 On Local Error Goto SQL_Error
917 vResult = oStatement.executeUpdate(_ReplaceSquareBrackets(pvSQL))
918 On Local Error Goto Error_Function
919 RunSQL = True
920
921 Exit_Function:
922 Exit Function
923 Error_Function:
924 TraceError(TRACEABORT, Err, &quot;RunSQL&quot;, Erl)
925 GoTo Exit_Function
926 SQL_Error:
927 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
928 Goto Exit_Function
929 End Function &apos; RunSQL V1.1.0
930
931 REM -----------------------------------------------------------------------------------------------------------------------
932 Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
933 &apos; Collect all tables in the database
934 &apos; pbCheck unpublished
935
936 Const cstThisSub = &quot;Database.TableDefs&quot;
937 If _ErrorHandler() Then On Local Error Goto Error_Function
938 Utils._SetCalledSub(cstThisSub)
939 If IsMissing(pbCheck) Then pbCheck = False
940
941 Dim sObjects() As String, sObjectName As String, oObject As Object
942 Dim i As Integer, bFound As Boolean, oTables As Object
943 Set oObject = Nothing
944 If Not IsMissing(pvIndex) Then
945 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
946 End If
947
948 Set oTables = Connection.getTables
949 sObjects = oTables.ElementNames()
950 Select Case True
951 Case IsMissing(pvIndex)
952 Set oObject = New Collect
953 oObject._CollType = COLLTABLEDEFS
954 oObject._ParentType = OBJDATABASE
955 oObject._ParentName = &quot;&quot;
956 Set oObject._ParentDatabase = _This
957 oObject._Count = UBound(sObjects) + 1
958 Goto Exit_Function
959 Case VarType(pvIndex) = vbString
960 bFound = False
961 &apos; Check existence of object and find its exact (case-sensitive) name
962 For i = 0 To UBound(sObjects)
963 If UCase(pvIndex) = UCase(sObjects(i)) Then
964 sObjectName = sObjects(i)
965 bFound = True
966 Exit For
967 End If
968 Next i
969 If Not bFound Then Goto Trace_NotFound
970 Case Else &apos; pvIndex is numeric
971 If pvIndex &lt; 0 Or pvIndex &gt; UBound(sObjects) Then Goto Trace_IndexError
972 sObjectName = sObjects(pvIndex)
973 End Select
974
975 Set oObject = New DataDef
976 With oObject
977 ._Type = OBJTABLEDEF
978 ._Name = sObjectName
979 Set ._ParentDatabase = _This
980 ._ReadOnly = _ReadOnly
981 Set .Table = oTables.getByName(sObjectName)
982 .CatalogName = .Table.CatalogName
983 .SchemaName = .Table.SchemaName
984 .TableName = .Table.Name
985 End With
986
987 Exit_Function:
988 Set TableDefs = oObject
989 Set oObject = Nothing
990 Utils._ResetCalledSub(cstThisSub)
991 Exit Function
992 Error_Function:
993 TraceError(TRACEABORT, Err, cstThisSub, Erl)
994 GoTo Exit_Function
995 Trace_NotFound:
996 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;TABLE&quot;), pvIndex))
997 Goto Exit_Function
998 Trace_IndexError:
999 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
1000 Goto Exit_Function
1001 End Function &apos; TableDefs V1.1.0
1002
1003 REM -----------------------------------------------------------------------------------------------------------------------
1004 REM --- PRIVATE FUNCTIONS ---
1005 REM -----------------------------------------------------------------------------------------------------------------------
1006
1007 REM -----------------------------------------------------------------------------------------------------------------------
1008 Private Function _DFunction(ByVal psFunction As String _
1009 , ByVal psExpr As String _
1010 , ByVal psDomain As String _
1011 , ByVal pvCriteria As Variant _
1012 , ByVal Optional pvOrderClause As Variant _
1013 ) As Variant
1014 &apos;Arguments: psFunction an optional aggregate function
1015 &apos; psExpr: an SQL expression [might contain an aggregate function]
1016 &apos; psDomain: a table- or queryname
1017 &apos; pvCriteria: an optional WHERE clause
1018 &apos; pcOrderClause: an optional order clause incl. &quot;DESC&quot; if relevant
1019
1020 If _ErrorHandler() Then On Local Error GoTo Error_Function
1021
1022 Dim oResult As Object &apos;To retrieve the value to find.
1023 Dim vResult As Variant &apos;Return value for function.
1024 Dim sSql As String &apos;SQL statement.
1025 Dim oStatement As Object &apos;For CreateStatement method
1026 Dim sExpr As String &apos;For inclusion of aggregate function
1027 Dim sTempField As String &apos;Random temporary field in SQL expression
1028
1029 Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String
1030
1031 vResult = Null
1032
1033 Randomize 2^14-1
1034 sTempField = &quot;[TEMP&quot; &amp; Right(&quot;00000&quot; &amp; Int(100000 * Rnd), 5) &amp; &quot;]&quot;
1035 If pvCriteria &lt;&gt; &quot;&quot; Then sWhere = &quot; WHERE &quot; &amp; pvCriteria Else sWhere = &quot;&quot;
1036 If pvOrderClause &lt;&gt; &quot;&quot; Then sOrderBy = &quot; ORDER BY &quot; &amp; pvOrderClause Else sOrderBy = &quot;&quot;
1037 sLimit = &quot;&quot;
1038
1039 Select Case UCase(MetaData.getDatabaseProductName())
1040 Case &quot;MYSQL&quot;, &quot;SQLITE&quot;
1041 If psFunction = &quot;&quot; Then
1042 sTarget = psExpr
1043 sLimit = &quot; LIMIT 1&quot;
1044 Else
1045 sTarget = UCase(psFunction) &amp; &quot;(&quot; &amp; psExpr &amp; &quot;)&quot;
1046 End If
1047 sSql = &quot;SELECT &quot; &amp; sTarget &amp; &quot; AS &quot; &amp; sTempField &amp; &quot; FROM &quot; &amp; psDomain &amp; sWhere &amp; sOrderBy &amp; sLimit
1048 Case Else &apos; Standard syntax - Includes HSQLDB
1049 If psFunction = &quot;&quot; Then sTarget = &quot;TOP 1 &quot; &amp; psExpr Else sTarget = UCase(psFunction) &amp; &quot;(&quot; &amp; psExpr &amp; &quot;)&quot;
1050 sSql = &quot;SELECT &quot; &amp; sTarget &amp; &quot; AS &quot; &amp; sTempField &amp; &quot; FROM &quot; &amp; psDomain &amp; sWhere &amp; sOrderBy
1051 End Select
1052
1053 &apos;Lookup the value.
1054 Set oStatement = Connection.createStatement()
1055 With oStatement
1056 .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
1057 .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
1058 .EscapeProcessing = False
1059 sSql = _ReplaceSquareBrackets(sSql) &apos;Substitute [] by quote string
1060 Set oResult = .executeQuery(sSql)
1061 If Not IsNull(oResult) And Not IsEmpty(oResult) Then
1062 If Not oResult.next() Then Goto Exit_Function
1063 vResult = Utils._getResultSetColumnValue(oResult, 1, True) &apos; Force return of binary field
1064 End If
1065 End With
1066
1067 Exit_Function:
1068 &apos;Assign the returned value.
1069 _DFunction = vResult
1070 Set oResult = Nothing
1071 Set oStatement = Nothing
1072 Exit Function
1073 Error_Function:
1074 TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
1075 Goto Exit_Function
1076 End Function &apos; DFunction V1.5.0
1077
1078 REM -----------------------------------------------------------------------------------------------------------------------
1079 Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String
1080 &apos; Return the default FilterOptions string for table/query export to csv
1081
1082 Dim sFieldSeparator as string
1083 Const cstComma = &quot;,&quot;
1084 Const cstTextDelimitor = &quot;&quot;&quot;&quot;
1085
1086 If _DecimalPoint() = &quot;,&quot; Then sFieldSeparator = &quot;;&quot; Else sFieldSeparator = cstComma
1087 _FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _
1088 &amp; cstComma &amp; Trim(Str(Asc(cstTextDelimitor))) _
1089 &amp; cstComma &amp; Trim(Str(plEncoding)) _
1090 &amp; cstComma &amp; &quot;1&quot;
1091
1092 End Function &apos; _FilterOptionsDefault V1.4.0
1093
1094 REM -----------------------------------------------------------------------------------------------------------------------
1095 Public Function _hasRecordset(ByVal psName As String) As Boolean
1096 &apos; Return True if psName if in the collection of Recordsets
1097
1098 Dim oRecordset As Object
1099 If _ErrorHandler() Then On Local Error Goto Error_Function
1100 Set oRecordset = RecordsetsColl.Item(psName)
1101 _hasRecordset = True
1102
1103 Exit_Function:
1104 Exit Function
1105 Error_Function: &apos; Item by key aborted
1106 _hasRecordset = False
1107 GoTo Exit_Function
1108 End Function &apos; _hasRecordset V0.9.5
1109
1110 REM -----------------------------------------------------------------------------------------------------------------------
1111 Private Sub _LoadMetadata()
1112 &apos; Load essentially getTypeInfo() results from Metadata
1113
1114 Dim sProduct As String
1115 Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer
1116
1117 Const cstMaxInfo = 40
1118 ReDim _ColumnTypes(0 To cstMaxInfo)
1119 ReDim _ColumnTypeNames(0 To cstMaxInfo)
1120 ReDim _ColumnPrecisions(0 To cstMaxInfo)
1121 Const cstHSQLDB1 = &quot;HSQL Database Engine 1.&quot;
1122 Const cstHSQLDB2 = &quot;HSQL Database Engine 2.&quot;
1123 Const cstMSAccess2003 = &quot;MS Jet 0&quot;
1124 Const cstMSAccess2007 = &quot;MS Jet 04.&quot;
1125 Const cstMYSQL = &quot;MySQL&quot;
1126 Const cstPOSTGRES = &quot;PostgreSQL&quot;
1127 Const cstSQLITE = &quot;SQLite&quot;
1128
1129 With com.sun.star.sdbc.DataType
1130 _ColumnTypesReference = Array( _
1131 .ARRAY _
1132 , .BIGINT _
1133 , .BINARY _
1134 , .BIT _
1135 , .BLOB _
1136 , .BOOLEAN _
1137 , .CHAR _
1138 , .CLOB _
1139 , .DATE _
1140 , .DECIMAL _
1141 , .DISTINCT _
1142 , .DOUBLE _
1143 , .FLOAT _
1144 , .INTEGER _
1145 , .LONGVARBINARY _
1146 , .LONGVARCHAR _
1147 , .NUMERIC _
1148 , .OBJECT _
1149 , .OTHER _
1150 , .REAL _
1151 , .REF _
1152 , .SMALLINT _
1153 , .SQLNULL _
1154 , .STRUCT _
1155 , .TIME _
1156 , .TIMESTAMP _
1157 , .TINYINT _
1158 , .VARBINARY _
1159 , .VARCHAR _
1160 )
1161 End With
1162
1163 With Metadata
1164 sProduct = .getDatabaseProductName() &amp; &quot; &quot; &amp; .getDatabaseProductVersion
1165 Select Case True
1166 Case Len(sProduct) &gt; Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
1167 _RDBMS = DBMS_HSQLDB1
1168 _ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12)
1169 _BinaryStream = True
1170 Case Len(sProduct) &gt; Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
1171 _RDBMS = DBMS_HSQLDB2
1172 _ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12)
1173 _BinaryStream = True
1174 Case Len(sProduct) &gt; Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
1175 _RDBMS = DBMS_MSACCESS2007
1176 _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
1177 _BinaryStream = True
1178 Case Len(sProduct) &gt; Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
1179 _RDBMS = DBMS_MSACCESS2003
1180 _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
1181 _BinaryStream = True
1182 Case Len(sProduct) &gt; Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL
1183 _RDBMS = DBMS_MYSQL
1184 _ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1)
1185 _BinaryStream = False
1186 Case Len(sProduct) &gt; Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
1187 _RDBMS = DBMS_POSTGRES
1188 _ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12)
1189 _BinaryStream = True
1190 Case Len(sProduct) &gt; Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE
1191 _RDBMS = DBMS_SQLITE
1192 _ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12)
1193 _BinaryStream = True
1194 Case Else &apos; Firebird TODO
1195 _RDBMS = DBMS_UNKNOWN
1196 _BinaryStream = True
1197 End Select
1198
1199 iInfo = -1
1200 Set oTypeInfo = MetaData.getTypeInfo()
1201 With oTypeInfo
1202 .next()
1203 Do While Not .isAfterLast() And iInfo &lt; cstMaxInfo
1204 sName = .getString(1)
1205 lType = .getLong(2)
1206 If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) &lt;&gt; &quot;_&quot; Or lType &lt;&gt; -1) Then &apos; Skip
1207 Else
1208 iInfo = iInfo + 1
1209 _ColumnTypeNames(iInfo) = sName
1210 _ColumnTypes(iInfo) = lType
1211 _ColumnPrecisions(iInfo) = .getLong(3)
1212 End If
1213 .next()
1214 Loop
1215 End With
1216 ReDim Preserve _ColumnTypes(0 To iInfo)
1217 ReDim Preserve _ColumnTypeNames(0 To iInfo)
1218 ReDim Preserve _ColumnPrecisions(0 To iInfo)
1219 End With
1220
1221 End Sub &apos; _LoadMetadata V1.6.0
1222
1223 REM -----------------------------------------------------------------------------------------------------------------------
1224 Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
1225 &apos; Converts input boolean value to HTML compatible string
1226
1227 _OutputBooleanToHTML = Iif(pbBool, &quot;&amp;#9745;&quot;, &quot;&amp;#9746;&quot;)
1228
1229 End Function &apos; _OutputBooleanToHTML V1.4.0
1230
1231 REM -----------------------------------------------------------------------------------------------------------------------
1232 Private Function _OutputClassToHTML(ByVal pvArray As variant) As String
1233 &apos; Formats classes attribute of &lt;tr&gt; and &lt;td&gt; tags
1234
1235 If Not IsArray(pvArray) Then
1236 _OutputClassToHTML = &quot;&quot;
1237 ElseIf UBound(pvArray) &lt; LBound(pvArray) Then
1238 _OutputClassToHTML = &quot;&quot;
1239 Else
1240 _OutputClassToHTML = &quot; class=&quot;&quot;&quot; &amp; Join(pvArray, &quot; &quot;) &amp; &quot;&quot;&quot;&quot;
1241 End If
1242
1243 End Function &apos; _OutputClassToHTML V1.4.0
1244
1245 REM -----------------------------------------------------------------------------------------------------------------------
1246 Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _
1247 , ByRef Optional pvHeaders As Variant _
1248 , ByRef Optional pvData As Variant _
1249 ) As Boolean
1250 &apos; Write html tags around data found in pvTable
1251 &apos; Exit when error without execution stop (to avoid file remaining open ...)
1252
1253 Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer
1254 Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant
1255 Dim bDataArray As Boolean, sHeader As String
1256 Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer
1257 Const cstMaxRows = 200
1258 On Local Error GoTo Error_Function
1259
1260 bDataArray = IsNull(pvTable)
1261 Print #piFile, &quot; &lt;table class=&quot;&quot;dbdatatable&quot;&quot;&gt;&quot;
1262 Print #piFile, &quot; &lt;caption&gt;&quot; &amp; pvName &amp; &quot;&lt;/caption&gt;&quot;
1263
1264 vFieldsBin() = Array()
1265 If bDataArray Then
1266 Set oTableRS = Nothing
1267 iNumFields = UBound(pvHeaders) + 1
1268 ReDim vFieldsBin(0 To iNumFields - 1)
1269 For i = 0 To iNumFields - 1
1270 vFieldsBin(i) = False
1271 Next i
1272 Else
1273 Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly)
1274 iNumFields = oTableRS.Fields.Count
1275 ReDim vFieldsBin(0 To iNumFields - 1)
1276 With com.sun.star.sdbc.DataType
1277 For i = 0 To iNumFields - 1
1278 iDataType = oTableRS.Fields(i).DataType
1279 vFieldsBin(i) = Utils._IsBinaryType(iDataType)
1280 Next i
1281 End With
1282 End If
1283
1284 With oTableRS
1285 Print #piFile, &quot; &lt;thead&gt;&quot;
1286 Print #piFile, &quot; &lt;tr&gt;&quot;
1287 For i = 0 To iNumFields - 1
1288 If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name
1289 Print #piFile, &quot; &lt;th scope=&quot;&quot;col&quot;&quot;&gt;&quot; &amp; sHeader &amp; &quot;&lt;/th&gt;&quot;
1290 Next i
1291 Print #piFile, &quot; &lt;/tr&gt;&quot;
1292 Print #piFile, &quot; &lt;/thead&gt;&quot;
1293 Print #piFile, &quot; &lt;tfoot&gt;&quot;
1294 Print #piFile, &quot; &lt;/tfoot&gt;&quot;
1295
1296 Print #piFile, &quot; &lt;tbody&gt;&quot;
1297 If bDataArray Then
1298 iLastRow = UBound(pvData, 2) + 1
1299 Else
1300 .MoveLast
1301 iLastRow = .RecordCount
1302 .MoveFirst
1303 End If
1304 iCountRows = 0
1305 Do While iCountRows &lt; iLastRow
1306 If bDataArray Then
1307 iNumRows = iLastRow
1308 Else
1309 vData() = .GetRows(cstMaxRows)
1310 iNumRows = UBound(vData, 2) + 1
1311 End If
1312 For j = 0 To iNumRows - 1
1313 iCountRows = iCountRows + 1
1314 vTrClass() = Array()
1315 If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, &quot;firstrow&quot;)
1316 If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, &quot;lastrow&quot;)
1317 If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, &quot;even&quot;) Else vTrClass() = _AddArray(vTrClass, &quot;odd&quot;)
1318 Print #piFile, &quot; &lt;tr&quot; &amp; _OutputClassToHTML(vTrClass) &amp; &quot;&gt;&quot;
1319 For i = 0 To iNumFields - 1
1320 vTdClass() = Array()
1321 If i = 0 Then vTdClass() = _AddArray(vTdClass, &quot;firstcol&quot;)
1322 If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, &quot;lastcol&quot;)
1323 If Not vFieldsBin(i) Then
1324 If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
1325 Select Case VarType(vDataCell)
1326 Case vbEmpty, vbNull
1327 vTdClass() = _AddArray(vTdClass, &quot;null&quot;)
1328 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputNullToHTML() &amp; &quot;&lt;/td&gt;&quot;
1329 Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt
1330 vTdClass() = _AddArray(vTdClass, &quot;numeric&quot;)
1331 If vDataCell &lt; 0 Then vTdClass() = _AddArray(vTdClass, &quot;negative&quot;)
1332 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputNumberToHTML(vDataCell) &amp; &quot;&lt;/td&gt;&quot;
1333 Case vbBoolean
1334 vTdClass() = _AddArray(vTdClass, &quot;bool&quot;)
1335 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputBooleanToHTML(vDataCell) &amp; &quot;&lt;/td&gt;&quot;
1336 Case vbDate
1337 vTdClass() = _AddArray(vTdClass, &quot;date&quot;)
1338 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputDateToHTML(vDataCell) &amp; &quot;&lt;/td&gt;&quot;
1339 Case vbString
1340 vTdClass() = _AddArray(vTdClass, &quot;char&quot;)
1341 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputStringToHTML(vDataCell) &amp; &quot;&lt;/td&gt;&quot;
1342 Case Else
1343 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _CStr(vDataCell) &amp; &quot;&lt;/td&gt;&quot;
1344 End Select
1345 Else &apos; Binary fields
1346 Print #piFile, &quot; &lt;td&quot; &amp; _OutputClassToHTML(vTdClass) &amp; &quot;&gt;&quot; &amp; _OutputBinaryToHTML() &amp; &quot;&lt;/td&gt;&quot;
1347 End If
1348 Next i
1349 Print #piFile, &quot; &lt;/tr&gt;&quot;
1350 Next j
1351 Loop
1352
1353 If Not bDataArray Then .mClose()
1354 End With
1355 Set oTableRS = Nothing
1356
1357 Print #piFile, &quot; &lt;/tbody&gt;&quot;
1358 Print #piFile, &quot; &lt;/table&gt;&quot;
1359 _OutputDataToHTML = True
1360
1361 Exit_Function:
1362 Exit Function
1363 Error_Function:
1364 TraceError(TRACEWARNING, Err, &quot;_OutputDataToHTML&quot;, Erl)
1365 _OutputDataToHTML = False
1366 Resume Exit_Function
1367 End Function &apos; _OutputDataToHTML V1.4.0
1368
1369 REM -----------------------------------------------------------------------------------------------------------------------
1370 Private Function _OutputBinaryToHTML() As String
1371 &apos; Converts Binary value to HTML compatible string
1372
1373 _OutputBinaryToHTML = &quot;&amp;nbsp;&quot;
1374
1375 End Function &apos; _OutputBinaryToHTML V1.4.0
1376
1377 REM -----------------------------------------------------------------------------------------------------------------------
1378 Private Function _OutputDateToHTML(ByVal psDate As Date) As String
1379 &apos; Converts input date to HTML compatible string
1380
1381 _OutputDateToHTML = Format(psDate) &apos; With regional settings - Ignores time if = to 0
1382
1383 End Function &apos; _OutputDateToHTML V1.4.0
1384
1385 REM -----------------------------------------------------------------------------------------------------------------------
1386 Private Function _OutputNullToHTML() As String
1387 &apos; Converts Null value to HTML compatible string
1388
1389 _OutputNullToHTML = &quot;&amp;nbsp;&quot;
1390
1391 End Function &apos; _OutputNullToHTML V1.4.0
1392
1393 REM -----------------------------------------------------------------------------------------------------------------------
1394 Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String
1395 &apos; Converts input number to HTML compatible string
1396
1397 Dim vNumber As Variant
1398 If IsMissing(piPrecision) Then piPrecision = -1
1399 If pvNumber = Int(pvNumber) Then
1400 vNumber = Int(pvNumber)
1401 Else
1402 If piPrecision &gt;= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber
1403 End If
1404 _OutputNumberToHTML = Format(vNumber)
1405
1406 End Function &apos; _OutputNumberToHTML V1.4.0
1407
1408 REM -----------------------------------------------------------------------------------------------------------------------
1409 Private Function _OutputStringToHTML(ByVal psString As String) As String
1410 &apos; Converts input string to HTML compatible string
1411 &apos; - UTF-8 encoding
1412 &apos; - recognition of next patterns
1413 &apos; - &amp;quot; - &amp;amp; - &amp;apos; - &amp;lt; - &amp;gt;
1414 &apos; - &lt;pre&gt;
1415 &apos; - &lt;a href=&quot;...
1416 &apos; - &lt;br&gt;
1417 &apos; - &lt;img src=&quot;...
1418 &apos; - &lt;b&gt;, &lt;u&gt;, &lt;i&gt;
1419
1420 Dim vPatterns As Variant
1421 Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String
1422 Dim sOutput As String, sChar As String
1423 Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean
1424 Dim i As Integer, l As Long
1425
1426 vPatterns = Array( _
1427 &quot;&amp;quot;&quot;, &quot;&amp;amp;&quot;, &quot;&amp;apos;&quot;, &quot;&amp;lt;&quot;, &quot;&amp;gt;&quot;, &quot;&amp;nbsp;&quot; _
1428 , &quot;&lt;pre&gt;&quot;, &quot;&lt;/pre&gt;&quot;, &quot;&lt;br&gt;&quot; _
1429 , &quot;&lt;a href=&quot;&quot;&quot;, &quot;&lt;a id=&quot;&quot;&quot;, &quot;&lt;/a&gt;&quot;, &quot;&lt;img src=&quot;&quot;&quot; _
1430 , &quot;&lt;span style=&quot;&quot;&quot;, &quot;&lt;/span&gt;&quot; _
1431 , &quot;&lt;b&gt;&quot;, &quot;&lt;/b&gt;&quot;, &quot;&lt;u&gt;&quot;, &quot;&lt;/u&gt;&quot;, &quot;&lt;i&gt;&quot;, &quot;&lt;/i&gt;&quot; _
1432 )
1433
1434 lCurrentChar = 1
1435 sOutput = &quot;&quot;
1436
1437 Do While lCurrentChar &lt;= Len(psString)
1438 &apos; Where is next closest pattern ?
1439 lPattern = Len(psString) + 1
1440 sPattern = &quot;&quot;
1441 For i = 0 To UBound(vPatterns)
1442 lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) &apos; Text (not case-sensitive) string comparison
1443 If lNextPattern &gt; 0 And lNextPattern &lt; lPattern Then
1444 lPattern = lNextPattern
1445 sPattern = Mid(psString, lPattern, Len(vPatterns(i)))
1446 End If
1447 Next i
1448 &apos; Up to the next pattern or to the end of the string, UTF8-encode each character
1449 For l = lCurrentChar To lPattern - 1
1450 sChar = Mid(psString, l, 1)
1451 sOutput = sOutput &amp; Utils._UTF8Encode(sChar)
1452 Next l
1453 &apos; Process hyperlink patterns and keep others
1454 If Len(sPattern) &gt; 0 Then
1455 Select Case LCase(sPattern)
1456 Case &quot;&lt;a href=&quot;&quot;&quot;, &quot;&lt;a id=&quot;&quot;&quot;, &quot;&lt;img src=&quot;&quot;&quot;, &quot;&lt;span style=&quot;&quot;&quot;
1457 &apos; Up to next quote, url-encode
1458 lNextQuote = 0
1459 lUrl = lPattern + Len(sPattern)
1460 lNextQuote = InStr(lUrl, psString, &quot;&quot;&quot;&quot;, 1)
1461 If lNextQuote = 0 Then lNextQuote = Len(psString) &apos; Should not happen but, if quoted string not closed ...
1462 sUrl = Mid(psString, lUrl, lNextQuote - lUrl)
1463 sOutput = sOutput &amp; sPattern &amp; Iif(sPattern = &quot;&lt;a id=&quot;&quot;&quot;, sUrl, ConvertToUrl(sUrl)) &amp; &quot;&quot;&quot;&quot;
1464 lCurrentChar = lNextQuote + 1
1465 bQuote = False
1466 bTagEnd = False
1467 Do
1468 sChar = Mid(psString, lCurrentChar, 1)
1469 Select Case sChar
1470 Case &quot;&quot;&quot;&quot;
1471 bQuote = Not bQuote
1472 sOutput = sOutput &amp; sChar
1473 Case &quot;&gt;&quot; &apos; Tag end if not somewhere between quotes
1474 If Not bQuote Then
1475 bTagEnd = True
1476 sOutput = sOutput &amp; sChar
1477 Else
1478 sOutput = sOutput &amp; _UTF8Encode(sChar)
1479 End If
1480 Case Else
1481 sOutput = sOutput &amp; _UTF8Encode(sChar)
1482 End Select
1483 lCurrentChar = lCurrentChar + 1
1484 If lCurrentChar &gt; Len(psString) Then bTagEnd = True &apos; Should not happen but, if tag not closed ...
1485 Loop Until bTagEnd
1486 Case Else
1487 sOutput = sOutput &amp; sPattern
1488 lCurrentChar = lPattern + Len(sPattern)
1489 End Select
1490 Else
1491 lCurrentChar = Len(psString) + 1
1492 End If
1493 Loop
1494
1495 _OutputStringToHTML = sOutput
1496
1497 End Function &apos; _OutputStringToHTML V1.4.0
1498
1499 REM -----------------------------------------------------------------------------------------------------------------------
1500 Private Function _OutputToCalc(poData As Object _
1501 , ByVal psOutputFile As String _
1502 , ByVal psFilter As String _
1503 , Optional ByVal plEncoding As Long _
1504 ) As Boolean
1505 &apos; https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Database_Import
1506 &apos; https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options
1507
1508 Dim oCalcDoc As Object, oSheet As Object, vWin As Variant
1509 Dim vImportDesc() As Variant, iSource As Integer
1510 Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object
1511
1512 If _ErrorHandler() Then On Local Error Goto Error_Function
1513 _OutputToCalc = False
1514 If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding
1515 &apos; Create a new OO-Calc-Document
1516 Set oCalcDoc = StarDesktop.LoadComponentFromURL( _
1517 &quot;private:factory/scalc&quot; _
1518 , &quot;_default&quot; ,0, Array() _
1519 )
1520
1521 &apos; Get the unique spreadsheet
1522 Set oSheet = oCalcDoc.Sheets(0)
1523
1524 &apos; Describe import
1525 With poData
1526 If ._Type = &quot;TABLEDEF&quot; Then
1527 iSource = com.sun.star.sheet.DataImportMode.TABLE
1528 Else
1529 iSource = com.sun.star.sheet.DataImportMode.QUERY
1530 End If
1531 vImportDesc = Array( _
1532 _MakePropertyValue(&quot;DatabaseName&quot;, URL) _
1533 , _MakePropertyValue(&quot;SourceType&quot;, iSource) _
1534 , _MakePropertyValue(&quot;SourceObject&quot;, ._Name) _
1535 )
1536 oSheet.Name = ._Name
1537 End With
1538
1539 &apos; Import
1540 oSheet.getCellByPosition(0, 0).doImport(vImportDesc())
1541
1542 Select Case psFilter
1543 Case acFormatODS, acFormatXLS, acFormatXLSX &apos; Formatting
1544 iCol = poData.Fields().Count
1545 Set oRange = oSheet.getCellRangeByPosition(0, 0, iCol - 1, 0)
1546 oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD
1547 oRange.CellBackColor = RGB(200, 200, 200)
1548 oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
1549 Set oColumns = oRange.getColumns()
1550 For i = 0 To iCol - 1
1551 oColumns.getByIndex(i).OptimalWidth = True
1552 Next i
1553 oCalcDoc.storeAsUrl(psOutputFile, Array( _
1554 _MakePropertyValue(&quot;FilterName&quot;, psFilter) _
1555 , _MakePropertyValue(&quot;Overwrite&quot;, True) _
1556 ))
1557 Case Else
1558 oCalcDoc.storeAsUrl(psOutputFile, Array( _
1559 _MakePropertyValue(&quot;FilterName&quot;, psFilter) _
1560 , _MakePropertyValue(&quot;FilterOptions&quot;, _FilterOptionsDefault(plEncoding)) _
1561 , _MakePropertyValue(&quot;Overwrite&quot;, True) _
1562 ))
1563 End Select
1564
1565 oCalcDoc.close(False)
1566 _OutputToCalc = True
1567
1568 Exit_Function:
1569 Set oColumns = Nothing
1570 Set oRange = Nothing
1571 Set oSheet = Nothing
1572 Set oCalcDoc = Nothing
1573 Exit Function
1574 Error_Function:
1575 TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
1576 Goto Exit_Function
1577 End Function &apos; OutputToCalc V1.4.0
1578
1579 REM -----------------------------------------------------------------------------------------------------------------------
1580 Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _
1581 , ByRef Optional pvHeaders As Variant _
1582 , ByRef Optional pvData As Variant _
1583 ) As Boolean
1584 &apos; http://www.ehow.com/how_5652706_create-html-template-ms-access.html
1585
1586 Dim bDataArray As Boolean
1587 Dim vMinimalTemplate As Variant, vTemplate As Variant
1588 Dim iFile As Integer, i As Integer, sLine As String, lBody As Long
1589 Const cstTitle = &quot;&lt;!--Template_Title--&gt;&quot;, cstBody = &quot;&lt;!--Template_Body--&gt;&quot;
1590 Const cstTitleAlt = &quot;&lt;!--AccessTemplate_Title--&gt;&quot;, cstBodyAlt = &quot;&lt;!--AccessTemplate_Body--&gt;&quot;
1591
1592 On Local Error GoTo Error_Function
1593 vMinimalTemplate = Array( _
1594 &quot;&lt;!DOCTYPE html&gt;&quot; _
1595 , &quot;&lt;html&gt;&quot; _
1596 , &quot; &lt;head&gt;&quot; _
1597 , &quot; &lt;title&gt;&quot; &amp; cstTitle &amp; &quot;&lt;/title&gt;&quot; _
1598 , &quot; &lt;/head&gt;&quot; _
1599 , &quot; &lt;body&gt;&quot; _
1600 , &quot; &quot; &amp; cstBody _
1601 , &quot; &lt;/body&gt;&quot; _
1602 , &quot;&lt;/html&gt;&quot; _
1603 )
1604
1605 vTemplate = _ReadFileIntoArray(psTemplateFile)
1606 If LBound(vTemplate) &gt; UBound(vTemplate) Then vTemplate() = vMinimalTemplate()
1607
1608 bDataArray = IsNull(pvTable)
1609
1610 &apos; Write output file
1611 iFile = FreeFile()
1612 Open psOutputFile For Output Access Write Lock Read Write As #iFile
1613 For i = 0 To UBound(vTemplate)
1614 sLine = vTemplate(i)
1615 sLine = Join(Split(sLine, cstTitleAlt), cstTitle)
1616 sLine = Join(Split(sLine, cstBodyAlt), cstBody)
1617 Select Case True
1618 Case InStr(sLine, cstTitle) &gt; 0
1619 sLine = Join(Split(sLine, cstTitle), pvName)
1620 Print #iFile, sLine
1621 Case InStr(sLine, cstBody) &gt; 0
1622 lBody = InStr(sLine, cstBody)
1623 If lBody &gt; 1 Then Print #iFile, Left(sLine, lBody - 1)
1624 If bDataArray Then
1625 _OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData)
1626 Else
1627 _OutputDataToHTML(pvTable, pvName, iFile)
1628 End If
1629 If Len(sLine) &gt; lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1)
1630 Case Else
1631 Print #iFile, sLine
1632 End Select
1633 Next i
1634 Close #iFile
1635
1636 _OutputToHTML = True
1637
1638 Exit_Function:
1639 Exit Function
1640 Error_Function:
1641 _OutputToHTML = False
1642 GoTo Exit_Function
1643 End Function &apos; _OutputToHTML V1.4.0
1644
1645 REM -----------------------------------------------------------------------------------------------------------------------
1646 Private Function _PropertiesList() As Variant
1647
1648 _PropertiesList = Array(&quot;Connect&quot;, &quot;Name&quot;, &quot;ObjectType&quot;, &quot;Version&quot;)
1649
1650 End Function &apos; _PropertiesList
1651
1652 REM -----------------------------------------------------------------------------------------------------------------------
1653 Private Function _PropertyGet(ByVal psProperty As String) As Variant
1654 &apos; Return property value of the psProperty property name
1655
1656 If _ErrorHandler() Then On Local Error Goto Error_Function
1657 Utils._SetCalledSub(&quot;Database.get&quot; &amp; psProperty)
1658 Dim vEMPTY As Variant
1659 _PropertyGet = vEMPTY
1660
1661 Select Case UCase(psProperty)
1662 Case UCase(&quot;Connect&quot;)
1663 _PropertyGet = Document.Datasource.URL
1664 &apos; Location = ConvertFromUrl(URL)
1665 Case UCase(&quot;Name&quot;)
1666 _PropertyGet = Title
1667 Case UCase(&quot;ObjectType&quot;)
1668 _PropertyGet = _Type
1669 Case UCase(&quot;Version&quot;)
1670 _PropertyGet = MetaData.getDatabaseProductName() &amp; &quot; &quot; &amp; MetaData.getDatabaseProductVersion
1671 Case Else
1672 Goto Trace_Error
1673 End Select
1674
1675 Exit_Function:
1676 Utils._ResetCalledSub(&quot;Database.get&quot; &amp; psProperty)
1677 Exit Function
1678 Trace_Error:
1679 TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
1680 _PropertyGet = vEMPTY
1681 Goto Exit_Function
1682 Error_Function:
1683 TraceError(TRACEABORT, Err, &quot;Database._PropertyGet&quot;, Erl)
1684 _PropertyGet = vEMPTY
1685 GoTo Exit_Function
1686 End Function &apos; _PropertyGet
1687
1688 REM -----------------------------------------------------------------------------------------------------------------------
1689 Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
1690 &apos; Returns psSql after substitution of [] by quote character
1691 &apos; [] square brackets in (single) quoted strings not affected
1692
1693 Dim sQuote As String &apos;RDBMS specific quote character
1694 Dim vSubStrings() As Variant, i As Integer
1695 Const cstSingleQuote = &quot;&apos;&quot;
1696
1697 sQuote = MetaData.IdentifierQuoteString
1698 If sQuote = &quot; &quot; Then &apos; IdentifierQuoteString returns a space &quot; &quot; if identifier quoting is not supported.
1699 _ReplaceSquareBrackets = Trim(psSql)
1700 Exit Function
1701 End If
1702 vSubStrings() = Split(psSql, cstSingleQuote)
1703 For i = 0 To UBound(vSubStrings)
1704 If (i Mod 2) = 0 Then &apos; Only even substrings are parsed for square brackets
1705 vSubStrings(i) = Join(Split(vSubStrings(i), &quot;[&quot;), sQuote)
1706 vSubStrings(i) = Join(Split(vSubStrings(i), &quot;]&quot;), sQuote)
1707 End If
1708 Next i
1709
1710 _ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote))
1711
1712 End Function &apos; ReplaceSquareBrackets V1.1.0
1713 </script:module>
FREE OFFICE SUITE