| blob | 347eafeb499dfcd99b8fc506f9135e825cf230a8 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Database" script:language="StarBasic">
4 REM =======================================================================================================================
5 REM === The Access2Base library is a part of the LibreOffice project. ===
6 REM === Full documentation is available on http://www.access2base.com ===
7 REM =======================================================================================================================
9 Option Compatible
10 Option ClassModule
12 Option Explicit
14 REM -----------------------------------------------------------------------------------------------------------------------
15 REM --- CLASS ROOT FIELDS ---
16 REM -----------------------------------------------------------------------------------------------------------------------
18 Private _Type As String ' Must be DATABASE
19 Private _This As Object ' Workaround for absence of This builtin function
20 Private _Parent As Object
21 Private _DbConnect As Integer ' DBCONNECTxxx constants
22 Private Title As String
23 Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
24 Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection
25 Private URL As String
26 Private Location As String ' Different from URL for registered databases
27 Private _ReadOnly As Boolean
28 Private MetaData As Object ' interface XDatabaseMetaData
29 Private _RDBMS As Integer ' DBMS constants
30 Private _ColumnTypes() As Variant ' Part of Metadata.GetTypeInfo()
31 Private _ColumnTypeNames() As Variant
32 Private _ColumnPrecisions() As Variant
33 Private _ColumnTypesReference() As Variant
34 Private _ColumnTypesAlias() As Variant ' To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods
35 Private _BinaryStream As Boolean ' False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes
36 Private Form As Object ' com.sun.star.form.XForm
37 Private FormName As String
39 Private RecordsetsColl As Object ' Collection of active recordsets
41 REM -----------------------------------------------------------------------------------------------------------------------
42 REM --- CONSTRUCTORS / DESTRUCTORS ---
43 REM -----------------------------------------------------------------------------------------------------------------------
44 Private Sub Class_Initialize()
45 _Type = OBJDATABASE
46 Set _This = Nothing
47 Set _Parent = Nothing
48 _DbConnect = 0
49 Title = ""
50 Set Document = Nothing
51 Set Connection = Nothing
52 URL = ""
53 _ReadOnly = False
54 Set MetaData = Nothing
55 _RDBMS = DBMS_UNKNOWN
56 _ColumnTypes = Array()
57 _ColumnTypeNames = Array()
58 _ColumnPrecisions = Array()
59 _ColumnTypesReference = Array()
60 _ColumnTypesAlias() = Array()
61 _BinaryStream = False
62 Set Form = Nothing
63 FormName = ""
64 RecordsetMax = 0
65 Set RecordsetsColl = New Collection
66 End Sub ' Constructor
68 REM -----------------------------------------------------------------------------------------------------------------------
69 Private Sub Class_Terminate()
70 On Local Error Resume Next
71 Call CloseAllRecordsets()
72 If _DbConnect <> DBCONNECTANY Then
73 If Not IsNull(Connection) Then
74 Connection.close()
75 Connection.dispose()
76 Set Connection = Nothing
77 End If
78 Else
79 mClose()
80 End If
81 Call Class_Initialize()
82 End Sub ' Destructor
84 REM -----------------------------------------------------------------------------------------------------------------------
85 Public Sub Dispose()
86 Call Class_Terminate()
87 End Sub ' Explicit destructor
91 REM -----------------------------------------------------------------------------------------------------------------------
92 REM --- CLASS GET/LET/SET PROPERTIES ---
93 REM -----------------------------------------------------------------------------------------------------------------------
95 Property Get Connect() As String
97 End Property ' Connect (get)
99 REM -----------------------------------------------------------------------------------------------------------------------
100 Property Get Name() As String
102 End Property ' Name (get)
104 REM -----------------------------------------------------------------------------------------------------------------------
105 Property Get ObjectType() As String
107 End Property ' ObjectType (get)
109 REM -----------------------------------------------------------------------------------------------------------------------
110 Property Get OnCreate() As String
112 End Property ' OnCreate (get)
114 REM -----------------------------------------------------------------------------------------------------------------------
115 Property Get OnFocus() As String
117 End Property ' OnFocus (get)
119 REM -----------------------------------------------------------------------------------------------------------------------
120 Property Get OnLoad() As String
122 End Property ' OnLoad (get)
124 REM -----------------------------------------------------------------------------------------------------------------------
125 Property Get OnLoadFinished() As String
127 End Property ' OnLoadFinished (get)
129 REM -----------------------------------------------------------------------------------------------------------------------
130 Property Get OnModifyChanged() As String
132 End Property ' OnModifyChanged (get)
134 REM -----------------------------------------------------------------------------------------------------------------------
135 Property Get OnNew() As String
137 End Property ' OnNew (get)
139 REM -----------------------------------------------------------------------------------------------------------------------
140 Property Get OnPrepareUnload() As String
142 End Property ' OnPrepareUnload (get)
144 REM -----------------------------------------------------------------------------------------------------------------------
145 Property Get OnPrepareViewClosing() As String
147 End Property ' OnPrepareViewClosing (get)
149 REM -----------------------------------------------------------------------------------------------------------------------
150 Property Get OnSave() As String
152 End Property ' OnSave (get)
154 REM -----------------------------------------------------------------------------------------------------------------------
155 Property Get OnSaveAs() As String
157 End Property ' OnSaveAs (get)
159 REM -----------------------------------------------------------------------------------------------------------------------
160 Property Get OnSaveAsDone() As String
162 End Property ' OnSaveAsDone (get)
164 REM -----------------------------------------------------------------------------------------------------------------------
165 Property Get OnSaveAsFailed() As String
167 End Property ' OnSaveAsFailed (get)
169 REM -----------------------------------------------------------------------------------------------------------------------
170 Property Get OnSaveDone() As String
172 End Property ' OnSaveDone (get)
174 REM -----------------------------------------------------------------------------------------------------------------------
175 Property Get OnSaveFailed() As String
177 End Property ' OnSaveFailed (get)
179 REM -----------------------------------------------------------------------------------------------------------------------
180 Property Get OnSubComponentClosed() As String
182 End Property ' OnSubComponentClosed (get)
184 REM -----------------------------------------------------------------------------------------------------------------------
185 Property Get OnSubComponentOpened() As String
187 End Property ' OnSubComponentOpened (get)
189 REM -----------------------------------------------------------------------------------------------------------------------
190 Property Get OnTitleChanged() As String
192 End Property ' OnTitleChanged (get)
194 REM -----------------------------------------------------------------------------------------------------------------------
195 Property Get OnUnfocus() As String
197 End Property ' OnUnfocus (get)
199 REM -----------------------------------------------------------------------------------------------------------------------
200 Property Get OnUnload() As String
202 End Property ' OnUnload (get)
204 REM -----------------------------------------------------------------------------------------------------------------------
205 Property Get OnViewClosed() As String
207 End Property ' OnViewClosed (get)
209 REM -----------------------------------------------------------------------------------------------------------------------
210 Property Get OnViewCreated() As String
212 End Property ' OnViewCreated (get)
214 REM -----------------------------------------------------------------------------------------------------------------------
215 Property Get Version() As String
217 End Property ' Version (get)
219 REM -----------------------------------------------------------------------------------------------------------------------
220 REM --- CLASS METHODS ---
221 REM -----------------------------------------------------------------------------------------------------------------------
223 REM -----------------------------------------------------------------------------------------------------------------------
224 Public Function mClose() As Variant
225 ' Close the database
227 If _ErrorHandler() Then On Local Error Goto Error_Function
229 Utils._SetCalledSub(cstThisSub)
230 mClose = False
231 If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable
233 With Connection
235 .close()
236 .dispose()
237 End With
238 Set Connection = Nothing
239 mClose = True
241 Exit_Function:
242 Utils._ResetCalledSub(cstThisSub)
243 Exit Function
244 Error_NotApplicable:
246 Goto Exit_Function
247 Error_Function:
248 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
249 GoTo Exit_Function
250 End Function ' (m)Close
252 REM -----------------------------------------------------------------------------------------------------------------------
253 Public Sub CloseAllRecordsets()
254 ' Clean all recordsets for housekeeping
256 Dim sRecordsets() As String, i As Integer, oRecordset As Object
257 On Local Error Goto Exit_Sub
259 If IsNull(RecordsetsColl) Then Exit Sub
261 For i = 1 To RecordsetsColl.Count
262 Set oRecordset = RecordsetsColl.Item(i)
263 oRecordset.mClose(False) ' Do not remove entry in collection
264 Next i
265 Set RecordsetsColl = New Collection
266 RecordsetMax = 0
268 Exit_Sub:
269 Exit Sub
272 REM -----------------------------------------------------------------------------------------------------------------------
273 Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
274 , ByVal Optional pvSql As Variant _
275 , ByVal Optional pvOption As Variant _
276 ) As Object
277 'Return a (new) QueryDef object based on SQL statement
279 Utils._SetCalledSub(cstThisSub)
281 Const cstNull = -1
282 Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String
284 If _ErrorHandler() Then On Local Error Goto Error_Function
286 Set CreateQueryDef = Nothing
287 If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
288 If IsMissing(pvQueryName) Then Call _TraceArguments()
289 If IsMissing(pvSql) Then Call _TraceArguments()
290 If IsMissing(pvOption) Then pvOption = cstNull
292 If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
293 If pvQueryName = "" Then Call _TraceArguments()
294 If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
295 If pvSql = "" Then Call _TraceArguments()
296 If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
298 If _ReadOnly Then Goto Error_NoUpdate
301 oQuery.rename(pvQueryName)
302 oQuery.Command = _ReplaceSquareBrackets(pvSql)
303 oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
305 Set oQueries = Document.DataSource.getQueryDefinitions()
306 With oQueries
308 sQueryName = .getByIndex(i).Name
309 If UCase(sQueryName) = UCase(pvQueryName) Then
310 TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
311 .removeByName(sQueryName)
312 Exit For
313 End If
314 Next i
315 .insertByName(pvQueryName, oQuery)
316 End With
317 Set CreateQueryDef = QueryDefs(pvQueryName)
319 Exit_Function:
320 Utils._ResetCalledSub(cstThisSub)
321 Exit Function
322 Error_NotApplicable:
324 Goto Exit_Function
325 Error_NoUpdate:
326 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
327 Goto Exit_Function
328 Error_Function:
329 TraceError(TRACEABORT, Err, cstThisSub, Erl)
330 GoTo Exit_Function
333 REM -----------------------------------------------------------------------------------------------------------------------
334 Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
335 'Return a (new/empty) TableDef object
337 Utils._SetCalledSub(cstThisSub)
339 Dim oTable As Object, oTables As Object, sTables() As String
340 Dim i As Integer, sTableName As String, oNewTable As Object
341 Dim vNameComponents() As Variant, iNames As Integer
343 If _ErrorHandler() Then On Local Error Goto Error_Function
345 Set CreateTableDef = Nothing
346 If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
347 If IsMissing(pvTableName) Then Call _TraceArguments()
349 If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
350 If pvTableName = "" Then Call _TraceArguments()
352 If _ReadOnly Then Goto Error_NoUpdate
354 Set oTables = Connection.getTables
355 With oTables
356 sTables = .ElementNames()
357 ' Check existence of object and find its exact (case-sensitive) name
358 For i = 0 To UBound(sTables)
359 If UCase(pvTableName) = UCase(sTables(i)) Then
360 sTableName = sTables(i)
361 TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
362 .dropByName(sTableName)
363 Exit For
364 End If
365 Next i
366 Set oNewTable = New DataDef
367 Set oNewTable._This = oNewTable
368 oNewTable._Type = OBJTABLEDEF
369 oNewTable._Name = pvTableName
371 iNames = UBound(vNameComponents)
372 If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = ""
373 If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = ""
374 oNewtable.TableName = vNameComponents(iNames)
375 Set oNewTable._ParentDatabase = _This
376 Set oNewTable.TableDescriptor = .createDataDescriptor()
377 oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
378 oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
379 oNewTable.TableDescriptor.Name = oNewTable.TableName
381 End With
383 Set CreateTabledef = oNewTable
385 Exit_Function:
386 Utils._ResetCalledSub(cstThisSub)
387 Exit Function
388 Error_NotApplicable:
390 Goto Exit_Function
391 Error_NoUpdate:
392 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
393 Goto Exit_Function
394 Error_Function:
395 TraceError(TRACEABORT, Err, cstThisSub, Erl)
396 GoTo Exit_Function
399 REM -----------------------------------------------------------------------------------------------------------------------
400 Public Function DAvg( _
401 ByVal Optional psExpr As String _
402 , ByVal Optional psDomain As String _
403 , ByVal Optional pvCriteria As Variant _
404 ) As Variant
405 ' Return average of scope
407 Utils._SetCalledSub(cstThisSub)
408 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
409 DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
410 Utils._ResetCalledSub(cstThisSub)
411 End Function ' DAvg
413 REM -----------------------------------------------------------------------------------------------------------------------
414 Public Function DCount( _
415 ByVal Optional psExpr As String _
416 , ByVal Optional psDomain As String _
417 , ByVal Optional pvCriteria As Variant _
418 ) As Variant
419 ' Return # of occurrences of scope
421 Utils._SetCalledSub(cstThisSub)
422 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
423 DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
424 Utils._ResetCalledSub(cstThisSub)
425 End Function ' DCount
427 REM -----------------------------------------------------------------------------------------------------------------------
428 Public Function DLookup( _
429 ByVal Optional psExpr As String _
430 , ByVal Optional psDomain As String _
431 , ByVal Optional pvCriteria As Variant _
432 , ByVal Optional pvOrderClause As Variant _
433 ) As Variant
435 ' Return a value within a table
436 'Arguments: psExpr: an SQL expression
437 ' psDomain: a table- or queryname
438 ' pvCriteria: an optional WHERE clause
440 'Return: Value of the psExpr if found, else Null.
442 'Examples:
444 ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
446 ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
449 Utils._SetCalledSub(cstThisSub)
450 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
451 DLookup = _DFunction("", psExpr, psDomain _
452 , Iif(IsMissing(pvCriteria), "", pvCriteria) _
453 , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
454 )
455 Utils._ResetCalledSub(cstThisSub)
456 End Function ' DLookup
458 REM -----------------------------------------------------------------------------------------------------------------------
459 Public Function DMax( _
460 ByVal Optional psExpr As String _
461 , ByVal Optional psDomain As String _
462 , ByVal Optional pvCriteria As Variant _
463 ) As Variant
464 ' Return maximum of scope
466 Utils._SetCalledSub(cstThisSub)
467 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
468 DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
469 Utils._ResetCalledSub(cstThisSub)
470 End Function ' DMax
472 REM -----------------------------------------------------------------------------------------------------------------------
473 Public Function DMin( _
474 ByVal Optional psExpr As String _
475 , ByVal Optional psDomain As String _
476 , ByVal Optional pvCriteria As Variant _
477 ) As Variant
478 ' Return minimum of scope
480 Utils._SetCalledSub(cstThisSub)
481 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
482 DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
483 Utils._ResetCalledSub(cstThisSub)
484 End Function ' DMin
486 REM -----------------------------------------------------------------------------------------------------------------------
487 Public Function DStDev( _
488 ByVal Optional psExpr As String _
489 , ByVal Optional psDomain As String _
490 , ByVal Optional pvCriteria As Variant _
491 ) As Variant
492 ' Return standard deviation of scope
494 Utils._SetCalledSub(cstThisSub)
495 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
496 DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
497 Utils._ResetCalledSub(cstThisSub)
498 End Function ' DStDev
500 REM -----------------------------------------------------------------------------------------------------------------------
501 Public Function DStDevP( _
502 ByVal Optional psExpr As String _
503 , ByVal Optional psDomain As String _
504 , ByVal Optional pvCriteria As Variant _
505 ) As Variant
506 ' Return standard deviation of scope
508 Utils._SetCalledSub(cstThisSub)
509 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
510 DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
511 Utils._ResetCalledSub(cstThisSub)
512 End Function ' DStDevP
514 REM -----------------------------------------------------------------------------------------------------------------------
515 Public Function DSum( _
516 ByVal Optional psExpr As String _
517 , ByVal Optional psDomain As String _
518 , ByVal Optional pvCriteria As Variant _
519 ) As Variant
520 ' Return sum of scope
522 Utils._SetCalledSub(cstThisSub)
523 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
524 DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
525 Utils._ResetCalledSub(cstThisSub)
526 End Function ' DSum
528 REM -----------------------------------------------------------------------------------------------------------------------
529 Public Function DVar( _
530 ByVal Optional psExpr As String _
531 , ByVal Optional psDomain As String _
532 , ByVal Optional pvCriteria As Variant _
533 ) As Variant
534 ' Return variance of scope
536 Utils._SetCalledSub(cstThisSub)
537 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
538 DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
539 Utils._ResetCalledSub(cstThisSub)
540 End Function ' DVar
542 REM -----------------------------------------------------------------------------------------------------------------------
543 Public Function DVarP( _
544 ByVal Optional psExpr As String _
545 , ByVal Optional psDomain As String _
546 , ByVal Optional pvCriteria As Variant _
547 ) As Variant
548 ' Return variance of scope
550 Utils._SetCalledSub(cstThisSub)
551 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
552 DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
553 Utils._ResetCalledSub(cstThisSub)
554 End Function ' DVarP
556 REM -----------------------------------------------------------------------------------------------------------------------
557 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
558 ' Return property value of psProperty property name
561 If IsMissing(pvProperty) Then Call _TraceArguments()
562 getProperty = _PropertyGet(pvProperty)
565 End Function ' getProperty
567 REM -----------------------------------------------------------------------------------------------------------------------
568 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
569 ' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
571 If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
572 Exit Function
574 End Function ' hasProperty
576 REM -----------------------------------------------------------------------------------------------------------------------
577 Public Function OpenRecordset(ByVal Optional pvSource As Variant _
578 , ByVal Optional pvType As Variant _
579 , ByVal Optional pvOptions As Variant _
580 , ByVal Optional pvLockEdit As Variant _
581 ) As Object
582 'Return a Recordset object based on Source (= SQL, table or query name)
585 Utils._SetCalledSub(cstThisSub)
586 Const cstNull = -1
588 Dim lCommandType As Long, sCommand As String, oObject As Object
589 Dim sSource As String, i As Integer, iCount As Integer
590 Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object
591 Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
593 If _ErrorHandler() Then On Local Error Goto Error_Function
594 Set oObject = Nothing
595 If IsMissing(pvSource) Then Call _TraceArguments()
596 If pvSource = "" Then Call _TraceArguments()
597 If VarType(pvType) = vbError Then
598 iType = cstNull
599 ElseIf IsMissing(pvType) Then
600 iType = cstNull
601 Else
602 If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
603 iType = pvType
604 End If
605 If VarType(pvOptions) = vbError Then
606 iOptions = cstNull
607 ElseIf IsMissing(pvOptions) Then
608 iOptions = cstNull
609 Else
610 If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
611 iOptions = pvOptions
612 End If
613 If VarType(pvLockEdit) = vbError Then
614 iLockEdit = cstNull
615 ElseIf IsMissing(pvLockEdit) Then
616 iLockEdit = cstNull
617 Else
618 If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
619 iLockEdit = pvLockEdit
620 End If
623 Select Case True
625 lCommandType = com.sun.star.sdb.CommandType.COMMAND
626 sCommand = _ReplaceSquareBrackets(pvSource)
627 Case Else
628 sSource = UCase(Trim(pvSource))
629 REM Explore tables
630 Set oTables = Connection.getTables
631 sObjects = oTables.ElementNames()
632 bFound = False
633 For i = 0 To UBound(sObjects)
634 If sSource = UCase(sObjects(i)) Then
635 sCommand = sObjects(i)
636 bFound = True
637 Exit For
638 End If
639 Next i
640 If bFound Then
641 lCommandType = com.sun.star.sdb.CommandType.TABLE
642 Else
643 REM Explore queries
644 Set oQueries = Connection.getQueries
645 sObjects = oQueries.ElementNames()
646 For i = 0 To UBound(sObjects)
647 If sSource = UCase(sObjects(i)) Then
648 sCommand = sObjects(i)
649 bFound = True
650 Exit For
651 End If
652 Next i
653 If Not bFound Then Goto Trace_NotFound
654 lCommandType = com.sun.star.sdb.CommandType.QUERY
655 End If
656 End Select
658 Set oObject = New Recordset
659 With oObject
660 ._CommandType = lCommandType
661 ._Command = sCommand
662 ._ParentName = Title
663 ._ParentType = _Type
664 ._ForwardOnly = ( iType = dbOpenForwardOnly )
665 ._PassThrough = ( iOptions = dbSQLPassThrough )
666 ._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
667 Set ._This = oObject
668 Set ._ParentDatabase = _This
669 Call ._Initialize()
670 RecordsetMax = RecordsetMax + 1
672 RecordsetsColl.Add(oObject, UCase(._Name))
673 End With
675 If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
677 Exit_Function:
678 Set OpenRecordset = oObject
679 Set oObject = Nothing
680 Utils._ResetCalledSub(cstThisSub)
681 Exit Function
682 Error_Function:
683 TraceError(TRACEABORT, Err, cstThisSub, Erl)
684 GoTo Exit_Function
685 Trace_NotFound:
686 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource))
687 Goto Exit_Function
690 REM -----------------------------------------------------------------------------------------------------------------------
691 Public Function OpenSQL(Optional ByVal pvSQL As Variant _
692 , Optional ByVal pvOption As Variant _
693 ) As Boolean
694 ' Return True if the execution of the SQL statement was successful
695 ' SQL must contain a SELECT query
696 ' pvOption can force pass through mode
698 If _ErrorHandler() Then On Local Error Goto Error_Function
701 Utils._SetCalledSub(cstThisSub)
703 OpenSQL = False
704 If IsMissing(pvSQL) Then Call _TraceArguments()
705 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
706 Const cstNull = -1
707 If IsMissing(pvOption) Then
708 pvOption = cstNull
709 Else
710 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function
711 End If
712 If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable
714 Dim oURL As New com.sun.star.util.URL, oDispatch As Object
715 Dim vArgs(8) as New com.sun.star.beans.PropertyValue
728 vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))
730 oDispatch.dispatch(oURL, vArgs)
731 OpenSQL = True
733 Exit_Function:
734 Exit Function
735 Error_Function:
737 GoTo Exit_Function
738 SQL_Error:
739 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
740 Goto Exit_Function
741 Error_NotApplicable:
743 Goto Exit_Function
746 REM -----------------------------------------------------------------------------------------------------------------------
747 Public Function OutputTo(ByVal pvObjectType As Variant _
748 , ByVal Optional pvObjectName As Variant _
749 , ByVal Optional pvOutputFormat As Variant _
750 , ByVal Optional pvOutputFile As Variant _
751 , ByVal Optional pvAutoStart As Variant _
752 , ByVal Optional pvTemplateFile As Variant _
753 , ByVal Optional pvEncoding As Variant _
754 , ByVal Optional pvQuality As Variant _
755 , ByRef Optional pvHeaders As Variant _
756 , ByRef Optional pvData As Variant _
757 ) As Boolean
758 'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries
759 'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray
761 If _ErrorHandler() Then On Local Error Goto Error_Function
763 Utils._SetCalledSub(cstThisSub)
765 OutputTo = False
767 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function
768 If IsMissing(pvObjectName) Then Call _TraceArguments()
769 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
770 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
771 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
772 If pvOutputFormat <> "" Then
773 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
779 , "")) _
781 End If
782 If IsMissing(pvOutputFile) Then pvOutputFile = ""
783 If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
784 If IsMissing(pvAutoStart) Then pvAutoStart = False
785 If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
786 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
787 If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
788 If IsMissing(pvEncoding) Then pvEncoding = 0
789 If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
790 If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
791 If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
792 If pvObjectType = acOutputArray Then
793 If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments()
795 End If
797 Dim sOutputFile As String, oTable As Object
798 Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String
800 If pvObjectType = acOutputArray Then
801 Set oTable = Nothing
802 Else
803 'Find applicable table or query
804 If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True)
805 If IsNull(oTable) Then Goto Error_NotFound
806 End If
808 'Determine format and parameters
809 If pvOutputFormat = "" Then
810 sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT")) ' Prompt user for format
811 If sOutputFormat = "" Then Goto Exit_Function
812 Else
813 sOutputFormat = UCase(pvOutputFormat)
814 End If
816 'Determine output file
818 Select Case sOutputFormat
824 End Select
825 sOutputFile = _PromptFilePicker(sSuffix)
826 If sOutputFile = "" Then Goto Exit_Function
827 Else
828 sOutputFile = pvOutputFile
829 End If
830 sOutputFile = ConvertToURL(sOutputFile)
832 'Create file
833 Select Case sOutputFormat
835 If pvObjectType = acOutputArray Then
836 bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData)
837 Else
838 bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile)
839 End If
841 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS)
843 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS)
845 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX)
847 bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding)
848 End Select
850 'Launch application, if requested
851 If bOutput Then
852 If pvAutoStart Then Call _ShellExecute(sOutputFile)
853 Else
854 GoTo Error_File
855 End If
857 OutputTo = True
859 Exit_Function:
860 If Not IsNull(oTable) Then
861 oTable.Dispose()
862 Set oTable = Nothing
863 End If
864 Utils._ResetCalledSub(cstThisSub)
865 Exit Function
866 Error_NotFound:
867 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
868 Goto Exit_Function
869 Error_Function:
870 TraceError(TRACEABORT, Err, cstThisSub, Erl)
871 GoTo Exit_Function
872 Error_File:
873 TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
874 GoTo Exit_Function
877 REM -----------------------------------------------------------------------------------------------------------------------
878 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
879 ' Return
880 ' a Collection object if pvIndex absent
881 ' a Property object otherwise
884 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
885 vPropertiesList = _PropertiesList()
886 sObject = Utils._PCase(_Type)
887 If IsMissing(pvIndex) Then
888 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
889 Else
890 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
891 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
892 End If
893 Set vProperty._ParentDatabase = _This
895 Exit_Function:
896 Set Properties = vProperty
898 Exit Function
899 End Function ' Properties
901 REM -----------------------------------------------------------------------------------------------------------------------
902 Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
903 ' Collect all Queries in the database
904 ' pbCheck unpublished
906 If _ErrorHandler() Then On Local Error Goto Error_Function
908 If IsMissing(pbCheck) Then pbCheck = False
910 Dim sObjects() As String, sObjectName As String, oObject As Object
911 Dim i As Integer, bFound As Boolean, oQueries As Object
912 Set oObject = Nothing
913 If Not IsMissing(pvIndex) Then
914 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
915 End If
917 Set oQueries = Connection.getQueries
918 sObjects = oQueries.ElementNames()
919 Select Case True
920 Case IsMissing(pvIndex)
921 Set oObject = New Collect
922 Set oObject._This = oObject
923 oObject._CollType = COLLQUERYDEFS
924 Set oObject._Parent = _This
925 oObject._Count = UBound(sObjects) + 1
926 Goto Exit_Function
927 Case VarType(pvIndex) = vbString
928 bFound = False
929 ' Check existence of object and find its exact (case-sensitive) name
930 For i = 0 To UBound(sObjects)
931 If UCase(pvIndex) = UCase(sObjects(i)) Then
932 sObjectName = sObjects(i)
933 bFound = True
934 Exit For
935 End If
936 Next i
937 If Not bFound Then Goto Trace_NotFound
938 Case Else ' pvIndex is numeric
940 sObjectName = sObjects(pvIndex)
941 End Select
943 Set oObject = New DataDef
944 Set oObject._This = oObject
945 oObject._Type = OBJQUERYDEF
946 oObject._Name = sObjectName
947 Set oObject._ParentDatabase = _This
948 oObject._readOnly = _ReadOnly
949 Set oObject.Query = oQueries.getByName(sObjectName)
951 Exit_Function:
952 Set QueryDefs = oObject
953 Set oObject = Nothing
955 Exit Function
956 Error_Function:
958 GoTo Exit_Function
959 Trace_NotFound:
960 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
961 Goto Exit_Function
962 Trace_IndexError:
963 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
964 Goto Exit_Function
967 REM -----------------------------------------------------------------------------------------------------------------------
968 Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
969 ' Collect all active recordsets
971 If _ErrorHandler() Then On Local Error Goto Error_Function
974 Set Recordsets = Nothing
975 If Not IsMissing(pvIndex) Then
976 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
977 End If
979 Dim sObjects() As String, sObjectName As String, oObject As Object
980 Dim i As Integer, bFound As Boolean, oTables As Object
982 Select Case True
983 Case IsMissing(pvIndex)
984 Set oObject = New Collect
985 Set oObject._This = oObject
986 oObject._CollType = COLLRECORDSETS
987 Set oObject._Parent = _This
988 oObject._Count = RecordsetsColl.Count
989 Case VarType(pvIndex) = vbString
990 bFound = _hasRecordset(pvIndex)
991 If Not bFound Then Goto Trace_NotFound
992 Set oObject = RecordsetsColl.Item(pvIndex)
993 Case Else ' pvIndex is numeric
995 Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numbered 1 ... Count
996 End Select
998 Exit_Function:
999 Set Recordsets = oObject
1000 Set oObject = Nothing
1002 Exit Function
1003 Error_Function:
1005 GoTo Exit_Function
1006 Trace_NotFound:
1007 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
1008 Goto Exit_Function
1009 Trace_IndexError:
1010 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
1011 Goto Exit_Function
1014 REM -----------------------------------------------------------------------------------------------------------------------
1015 Public Function RunSQL(Optional ByVal pvSQL As Variant _
1016 , Optional ByVal pvOption As Variant _
1017 ) As Boolean
1018 ' Return True if the execution of the SQL statement was successful
1019 ' SQL must contain an ACTION query
1021 If _ErrorHandler() Then On Local Error Goto Error_Function
1024 Utils._SetCalledSub(cstThisSub)
1026 RunSQL = False
1027 If IsMissing(pvSQL) Then Call _TraceArguments()
1028 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
1029 Const cstNull = -1
1030 If IsMissing(pvOption) Then
1031 pvOption = cstNull
1032 Else
1033 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
1034 End If
1036 Dim oStatement As Object, vResult As Variant
1037 Set oStatement = Connection.createStatement()
1038 oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
1039 On Local Error Goto SQL_Error
1040 vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL))
1041 On Local Error Goto Error_Function
1042 RunSQL = True
1044 Exit_Function:
1045 Utils._ResetCalledSub(cstThisSub)
1046 Exit Function
1047 Error_Function:
1048 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1049 GoTo Exit_Function
1050 SQL_Error:
1051 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
1052 Goto Exit_Function
1055 REM -----------------------------------------------------------------------------------------------------------------------
1056 Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
1057 ' Collect all tables in the database
1058 ' pbCheck unpublished
1061 If _ErrorHandler() Then On Local Error Goto Error_Function
1062 Utils._SetCalledSub(cstThisSub)
1063 If IsMissing(pbCheck) Then pbCheck = False
1065 Dim sObjects() As String, sObjectName As String, oObject As Object
1066 Dim i As Integer, bFound As Boolean, oTables As Object
1067 Set oObject = Nothing
1068 If Not IsMissing(pvIndex) Then
1069 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
1070 End If
1072 Set oTables = Connection.getTables
1073 sObjects = oTables.ElementNames()
1074 Select Case True
1075 Case IsMissing(pvIndex)
1076 Set oObject = New Collect
1077 Set oObject._This = oObject
1078 oObject._CollType = COLLTABLEDEFS
1079 Set oObject._Parent = _This
1080 oObject._Count = UBound(sObjects) + 1
1081 Goto Exit_Function
1082 Case VarType(pvIndex) = vbString
1083 bFound = False
1084 ' Check existence of object and find its exact (case-sensitive) name
1085 For i = 0 To UBound(sObjects)
1086 If UCase(pvIndex) = UCase(sObjects(i)) Then
1087 sObjectName = sObjects(i)
1088 bFound = True
1089 Exit For
1090 End If
1091 Next i
1092 If Not bFound Then Goto Trace_NotFound
1093 Case Else ' pvIndex is numeric
1095 sObjectName = sObjects(pvIndex)
1096 End Select
1098 Set oObject = New DataDef
1099 With oObject
1100 ._This = oObject
1101 ._Type = OBJTABLEDEF
1102 ._Name = sObjectName
1103 Set ._ParentDatabase = _This
1104 ._ReadOnly = _ReadOnly
1105 Set .Table = oTables.getByName(sObjectName)
1106 .CatalogName = .Table.CatalogName
1107 .SchemaName = .Table.SchemaName
1108 .TableName = .Table.Name
1109 End With
1111 Exit_Function:
1112 Set TableDefs = oObject
1113 Set oObject = Nothing
1114 Utils._ResetCalledSub(cstThisSub)
1115 Exit Function
1116 Error_Function:
1117 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1118 GoTo Exit_Function
1119 Trace_NotFound:
1120 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
1121 Goto Exit_Function
1122 Trace_IndexError:
1123 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
1124 Goto Exit_Function
1127 REM -----------------------------------------------------------------------------------------------------------------------
1128 REM --- PRIVATE FUNCTIONS ---
1129 REM -----------------------------------------------------------------------------------------------------------------------
1131 REM -----------------------------------------------------------------------------------------------------------------------
1132 Private Function _DFunction(ByVal psFunction As String _
1133 , ByVal psExpr As String _
1134 , ByVal psDomain As String _
1135 , ByVal pvCriteria As Variant _
1136 , ByVal Optional pvOrderClause As Variant _
1137 ) As Variant
1138 'Arguments: psFunction an optional aggregate function
1139 ' psExpr: an SQL expression [might contain an aggregate function]
1140 ' psDomain: a table- or queryname
1141 ' pvCriteria: an optional WHERE clause
1144 If _ErrorHandler() Then On Local Error GoTo Error_Function
1146 Dim oResult As Object 'To retrieve the value to find.
1147 Dim vResult As Variant 'Return value for function.
1148 Dim sSql As String 'SQL statement.
1149 Dim oStatement As Object 'For CreateStatement method
1150 Dim sExpr As String 'For inclusion of aggregate function
1151 Dim sTempField As String 'Random temporary field in SQL expression
1153 Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String
1154 Dim sProductName As String
1156 vResult = Null
1159 sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]"
1160 If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
1161 If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
1162 sLimit = ""
1164 sProductName = UCase(MetaData.getDatabaseProductName())
1166 Select Case sProductName
1168 If psFunction = "" Then
1169 sTarget = psExpr
1171 Else
1173 End If
1174 sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy & sLimit
1176 If psFunction = "" Then sTarget = "FIRST 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
1177 sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
1178 Case Else ' Standard syntax - Includes HSQLDB
1179 If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
1180 sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
1181 End Select
1183 'Lookup the value.
1184 Set oStatement = Connection.createStatement()
1185 With oStatement
1186 .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
1187 .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
1188 .EscapeProcessing = False
1189 sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
1190 Set oResult = .executeQuery(sSql)
1191 If Not IsNull(oResult) And Not IsEmpty(oResult) Then
1192 If Not oResult.next() Then Goto Exit_Function
1194 End If
1195 End With
1197 Exit_Function:
1198 'Assign the returned value.
1199 _DFunction = vResult
1200 Set oResult = Nothing
1201 Set oStatement = Nothing
1202 Exit Function
1203 Error_Function:
1204 TraceError(TRACEFATAL, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
1205 Goto Exit_Function
1208 REM -----------------------------------------------------------------------------------------------------------------------
1209 Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String
1210 ' Return the default FilterOptions string for table/query export to csv
1212 Dim sFieldSeparator as string
1214 Const cstTextDelimitor = """"
1216 If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma
1217 _FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _
1224 REM -----------------------------------------------------------------------------------------------------------------------
1225 Public Function _hasRecordset(ByVal psName As String) As Boolean
1226 ' Return True if psName if in the collection of Recordsets
1228 Dim oRecordset As Object
1229 If _ErrorHandler() Then On Local Error Goto Error_Function
1230 Set oRecordset = RecordsetsColl.Item(psName)
1231 _hasRecordset = True
1233 Exit_Function:
1234 Exit Function
1235 Error_Function: ' Item by key aborted
1236 _hasRecordset = False
1237 GoTo Exit_Function
1240 REM -----------------------------------------------------------------------------------------------------------------------
1241 Private Sub _LoadMetadata()
1242 ' Load essentially getTypeInfo() results from Metadata
1244 Dim sProduct As String
1245 Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer
1247 Const cstMaxInfo = 40
1248 ReDim _ColumnTypes(0 To cstMaxInfo)
1249 ReDim _ColumnTypeNames(0 To cstMaxInfo)
1250 ReDim _ColumnPrecisions(0 To cstMaxInfo)
1260 With com.sun.star.sdbc.DataType
1261 _ColumnTypesReference = Array( _
1262 .ARRAY _
1263 , .BIGINT _
1264 , .BINARY _
1265 , .BIT _
1266 , .BLOB _
1267 , .BOOLEAN _
1268 , .CHAR _
1269 , .CLOB _
1270 , .DATE _
1271 , .DECIMAL _
1272 , .DISTINCT _
1273 , .DOUBLE _
1274 , .FLOAT _
1275 , .INTEGER _
1276 , .LONGVARBINARY _
1277 , .LONGVARCHAR _
1278 , .NUMERIC _
1279 , .OBJECT _
1280 , .OTHER _
1281 , .REAL _
1282 , .REF _
1283 , .SMALLINT _
1284 , .SQLNULL _
1285 , .STRUCT _
1286 , .TIME _
1287 , .TIMESTAMP _
1288 , .TINYINT _
1289 , .VARBINARY _
1290 , .VARCHAR _
1291 )
1292 End With
1294 With Metadata
1295 sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion
1296 Select Case True
1297 Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
1298 _RDBMS = DBMS_HSQLDB1
1299 _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)
1300 _BinaryStream = True
1301 Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
1302 _RDBMS = DBMS_HSQLDB2
1303 _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)
1304 _BinaryStream = True
1306 _RDBMS = DBMS_FIREBIRD
1307 _ColumnTypesAlias = Array(0, -5, -2, 16, 2004, 16, 1, 2005, 91, 3, 0, 8, 6, 4, -4, 2005, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12)
1308 _BinaryStream = True
1309 Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
1310 _RDBMS = DBMS_MSACCESS2007
1311 _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)
1312 _BinaryStream = True
1313 Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
1314 _RDBMS = DBMS_MSACCESS2003
1315 _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)
1316 _BinaryStream = True
1317 Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL
1318 _RDBMS = DBMS_MYSQL
1319 _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)
1320 _BinaryStream = False
1321 Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
1322 _RDBMS = DBMS_POSTGRES
1323 _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)
1324 _BinaryStream = True
1325 Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE
1326 _RDBMS = DBMS_SQLITE
1327 _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)
1328 _BinaryStream = True
1329 Case Else
1330 _RDBMS = DBMS_UNKNOWN
1331 _BinaryStream = True
1332 End Select
1334 iInfo = -1
1335 Set oTypeInfo = MetaData.getTypeInfo()
1336 With oTypeInfo
1337 .next()
1338 Do While Not .isAfterLast() And iInfo < cstMaxInfo
1339 sName = .getString(1)
1340 lType = .getLong(2)
1341 If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then ' Skip
1342 Else
1343 iInfo = iInfo + 1
1344 _ColumnTypeNames(iInfo) = sName
1345 _ColumnTypes(iInfo) = lType
1346 _ColumnPrecisions(iInfo) = CLng(.getLong(3))
1347 End If
1348 .next()
1349 Loop
1350 End With
1351 ReDim Preserve _ColumnTypes(0 To iInfo)
1352 ReDim Preserve _ColumnTypeNames(0 To iInfo)
1353 ReDim Preserve _ColumnPrecisions(0 To iInfo)
1354 End With
1358 REM -----------------------------------------------------------------------------------------------------------------------
1359 Private Function _OutputBinaryToHTML() As String
1360 ' Converts Binary value to HTML compatible string
1366 REM -----------------------------------------------------------------------------------------------------------------------
1367 Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
1368 ' Converts input boolean value to HTML compatible string
1370 _OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;") ' ✔ and ✖
1374 REM -----------------------------------------------------------------------------------------------------------------------
1375 Private Function _OutputClassToHTML(ByVal pvArray As Variant) As String
1378 If Not IsArray(pvArray) Then
1379 _OutputClassToHTML = ""
1380 ElseIf UBound(pvArray) < LBound(pvArray) Then
1381 _OutputClassToHTML = ""
1382 Else
1383 _OutputClassToHTML = " class=""" & Join(pvArray, " ") & """"
1384 End If
1388 REM -----------------------------------------------------------------------------------------------------------------------
1389 Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _
1390 , ByRef Optional pvHeaders As Variant _
1391 , ByRef Optional pvData As Variant _
1392 ) As Boolean
1393 ' Write html tags around data found in pvTable
1394 ' Exit when error without execution stop (to avoid file remaining open ...)
1396 Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer
1397 Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant
1398 Dim bDataArray As Boolean, sHeader As String
1399 Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer
1400 Const cstMaxRows = 200
1401 On Local Error GoTo Error_Function
1403 bDataArray = IsNull(pvTable)
1407 vFieldsBin() = Array()
1408 If bDataArray Then
1409 Set oTableRS = Nothing
1410 iNumFields = UBound(pvHeaders) + 1
1413 vFieldsBin(i) = False
1414 Next i
1415 Else
1416 Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly)
1417 iNumFields = oTableRS.Fields.Count
1419 With com.sun.star.sdbc.DataType
1421 iDataType = oTableRS.Fields(i).DataType
1422 vFieldsBin(i) = Utils._IsBinaryType(iDataType)
1423 Next i
1424 End With
1425 End If
1427 With oTableRS
1431 If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name
1432 Print #piFile, " <th scope=""col"">" & sHeader & "</th>"
1433 Next i
1440 If bDataArray Then
1442 Else
1443 .MoveLast
1444 iLastRow = .RecordCount
1445 .MoveFirst
1446 End If
1447 iCountRows = 0
1448 Do While iCountRows < iLastRow
1449 If bDataArray Then
1450 iNumRows = iLastRow
1451 Else
1452 vData() = .GetRows(cstMaxRows)
1454 End If
1456 iCountRows = iCountRows + 1
1457 vTrClass() = Array()
1460 If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd")
1463 vTdClass() = Array()
1466 If Not vFieldsBin(i) Then
1467 If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
1468 If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull
1469 If VarType(vDataCell) = vbString Then ' Null string gives IsDate = True !
1471 End If
1472 Select Case VarType(vDataCell)
1473 Case vbEmpty, vbNull
1475 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>"
1476 Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt
1479 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>"
1480 Case vbBoolean
1483 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>"
1484 Case vbDate
1486 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>"
1487 Case vbString
1489 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>"
1490 Case Else
1491 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>"
1492 End Select
1493 Else ' Binary fields
1494 Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>"
1495 End If
1496 Next i
1498 Next j
1499 Loop
1501 If Not bDataArray Then .mClose()
1502 End With
1503 Set oTableRS = Nothing
1507 _OutputDataToHTML = True
1509 Exit_Function:
1510 Exit Function
1511 Error_Function:
1513 _OutputDataToHTML = False
1514 Resume Exit_Function
1517 REM -----------------------------------------------------------------------------------------------------------------------
1518 Private Function _OutputDateToHTML(ByVal psDate As Date) As String
1519 ' Converts input date to HTML compatible string
1525 REM -----------------------------------------------------------------------------------------------------------------------
1526 Private Function _OutputNullToHTML() As String
1527 ' Converts Null value to HTML compatible string
1533 REM -----------------------------------------------------------------------------------------------------------------------
1534 Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String
1535 ' Converts input number to HTML compatible string
1537 Dim vNumber As Variant
1538 If IsMissing(piPrecision) Then piPrecision = -1
1539 If pvNumber = Int(pvNumber) Then
1540 vNumber = Int(pvNumber)
1541 Else
1542 If piPrecision >= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber
1543 End If
1544 _OutputNumberToHTML = Format(vNumber)
1548 REM -----------------------------------------------------------------------------------------------------------------------
1549 Private Function _OutputStringToHTML(ByVal psString As String) As String
1550 ' Converts input string to HTML compatible string
1552 ' - recognition of next patterns
1560 Dim vPatterns As Variant
1561 Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String
1562 Dim sOutput As String, sChar As String
1563 Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean
1564 Dim i As Integer, l As Long
1566 vPatterns = Array( _
1567 "&quot;", "&amp;", "&apos;", "&lt;", "&gt;", "&nbsp;" _
1569 , "<a href=""", "<a id=""", "</a>", "<img src=""" _
1571 , "<b>", "</b>", "<u>", "</u>", "<i>", "</i>" _
1572 )
1574 lCurrentChar = 1
1575 sOutput = ""
1577 Do While lCurrentChar <= Len(psString)
1578 ' Where is next closest pattern ?
1579 lPattern = Len(psString) + 1
1580 sPattern = ""
1581 For i = 0 To UBound(vPatterns)
1582 lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) ' Text (not case-sensitive) string comparison
1584 lPattern = lNextPattern
1585 sPattern = Mid(psString, lPattern, Len(vPatterns(i)))
1586 End If
1587 Next i
1588 ' Up to the next pattern or to the end of the string, UTF8-encode each character
1589 For l = lCurrentChar To lPattern - 1
1590 sChar = Mid(psString, l, 1)
1591 sOutput = sOutput & Utils._UTF8Encode(sChar)
1592 Next l
1593 ' Process hyperlink patterns and keep others
1595 Select Case LCase(sPattern)
1596 Case "<a href=""", "<a id=""", "<img src=""", "<span class="""
1597 ' Up to next quote, url-encode
1598 lNextQuote = 0
1599 lUrl = lPattern + Len(sPattern)
1601 If lNextQuote = 0 Then lNextQuote = Len(psString) ' Should not happen but, if quoted string not closed ...
1602 sUrl = Mid(psString, lUrl, lNextQuote - lUrl)
1604 lCurrentChar = lNextQuote + 1
1605 bQuote = False
1606 bTagEnd = False
1607 Do
1608 sChar = Mid(psString, lCurrentChar, 1)
1609 Select Case sChar
1610 Case """"
1611 bQuote = Not bQuote
1612 sOutput = sOutput & sChar
1613 Case ">" ' Tag end if not somewhere between quotes
1614 If Not bQuote Then
1615 bTagEnd = True
1616 sOutput = sOutput & sChar
1617 Else
1618 sOutput = sOutput & _UTF8Encode(sChar)
1619 End If
1620 Case Else
1621 sOutput = sOutput & _UTF8Encode(sChar)
1622 End Select
1623 lCurrentChar = lCurrentChar + 1
1624 If lCurrentChar > Len(psString) Then bTagEnd = True ' Should not happen but, if tag not closed ...
1625 Loop Until bTagEnd
1626 Case Else
1627 sOutput = sOutput & sPattern
1628 lCurrentChar = lPattern + Len(sPattern)
1629 End Select
1630 Else
1631 lCurrentChar = Len(psString) + 1
1632 End If
1633 Loop
1635 _OutputStringToHTML = sOutput
1639 REM -----------------------------------------------------------------------------------------------------------------------
1640 Private Function _OutputToCalc(poData As Object _
1641 , ByVal psOutputFile As String _
1642 , ByVal psFilter As String _
1643 , Optional ByVal plEncoding As Long _
1644 ) As Boolean
1645 ' https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Database_Import
1646 ' https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options
1648 Dim oCalcDoc As Object, oSheet As Object, vWin As Variant
1649 Dim vImportDesc() As Variant, iSource As Integer
1650 Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object
1652 If _ErrorHandler() Then On Local Error Goto Error_Function
1653 _OutputToCalc = False
1654 If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding
1655 ' Create a new OO-Calc-Document
1656 Set oCalcDoc = StarDesktop.LoadComponentFromURL( _
1659 )
1661 ' Get the unique spreadsheet
1662 Set oSheet = oCalcDoc.Sheets(0)
1664 ' Describe import
1665 With poData
1667 iSource = com.sun.star.sheet.DataImportMode.TABLE
1668 Else
1669 iSource = com.sun.star.sheet.DataImportMode.QUERY
1670 End If
1671 vImportDesc = Array( _
1675 )
1676 oSheet.Name = ._Name
1677 End With
1679 ' Import
1682 Select Case psFilter
1683 Case acFormatODS, acFormatXLS, acFormatXLSX ' Formatting
1684 iCol = poData.Fields().Count
1686 oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD
1688 oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
1689 Set oColumns = oRange.getColumns()
1691 oColumns.getByIndex(i).OptimalWidth = True
1692 Next i
1693 oCalcDoc.storeAsUrl(psOutputFile, Array( _
1696 ))
1697 Case Else
1698 oCalcDoc.storeAsUrl(psOutputFile, Array( _
1702 ))
1703 End Select
1705 oCalcDoc.close(False)
1706 _OutputToCalc = True
1708 Exit_Function:
1709 Set oColumns = Nothing
1710 Set oRange = Nothing
1711 Set oSheet = Nothing
1712 Set oCalcDoc = Nothing
1713 Exit Function
1714 Error_Function:
1715 TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
1716 Goto Exit_Function
1719 REM -----------------------------------------------------------------------------------------------------------------------
1720 Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _
1721 , ByRef Optional pvHeaders As Variant _
1722 , ByRef Optional pvData As Variant _
1723 ) As Boolean
1724 ' http://www.ehow.com/how_5652706_create-html-template-ms-access.html
1726 Dim bDataArray As Boolean
1727 Dim vMinimalTemplate As Variant, vTemplate As Variant
1728 Dim iFile As Integer, i As Integer, sLine As String, lBody As Long
1729 Const cstTitle = "<!--Template_Title-->", cstBody = "<!--Template_Body-->"
1730 Const cstTitleAlt = "<!--AccessTemplate_Title-->", cstBodyAlt = "<!--AccessTemplate_Body-->"
1732 On Local Error GoTo Error_Function
1733 vMinimalTemplate = Array( _
1740 , " " & cstBody _
1743 )
1745 vTemplate = _ReadFileIntoArray(psTemplateFile)
1746 If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() = vMinimalTemplate()
1748 bDataArray = IsNull(pvTable)
1750 ' Write output file
1751 iFile = FreeFile()
1752 Open psOutputFile For Output Access Write Lock Read Write As #iFile
1753 For i = 0 To UBound(vTemplate)
1754 sLine = vTemplate(i)
1755 sLine = Join(Split(sLine, cstTitleAlt), cstTitle)
1756 sLine = Join(Split(sLine, cstBodyAlt), cstBody)
1757 Select Case True
1759 sLine = Join(Split(sLine, cstTitle), pvName)
1760 Print #iFile, sLine
1762 lBody = InStr(sLine, cstBody)
1764 If bDataArray Then
1765 _OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData)
1766 Else
1767 _OutputDataToHTML(pvTable, pvName, iFile)
1768 End If
1769 If Len(sLine) > lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1)
1770 Case Else
1771 Print #iFile, sLine
1772 End Select
1773 Next i
1774 Close #iFile
1776 _OutputToHTML = True
1778 Exit_Function:
1779 Exit Function
1780 Error_Function:
1781 _OutputToHTML = False
1782 GoTo Exit_Function
1785 REM -----------------------------------------------------------------------------------------------------------------------
1786 Private Function _PropertiesList() As Variant
1789 , "OnCreate", "OnFocus", "OnLoad", "OnLoadFinished", "OnModifyChanged" _
1790 , "OnNew", "OnPrepareUnload", "OnPrepareViewClosing", "OnSave", "OnSaveAs" _
1791 , "OnSaveAsDone", "OnSaveAsFailed", "OnSaveDone", "OnSaveFailed", "OnSaveTo" _
1792 , "OnSaveToDone", "OnSaveToFailed", "OnSubComponentClosed", "OnSubComponentOpened" _
1793 , "OnTitleChanged", "OnUnfocus", "OnUnload", "OnViewClosed", "OnViewCreated" _
1795 )
1797 End Function ' _PropertiesList
1799 REM -----------------------------------------------------------------------------------------------------------------------
1800 Private Function _PropertyGet(ByVal psProperty As String) As Variant
1801 ' Return property value of the psProperty property name
1803 Dim i As Integer, vEvents As Variant, sEvent As String, vEvent As Variant
1805 If _ErrorHandler() Then On Local Error Goto Error_Function
1808 _PropertyGet = EMPTY
1810 Select Case UCase(psProperty)
1812 If IsNull(Document) Then _PropertyGet = "" Else _PropertyGet = Document.Datasource.URL
1813 ' Location = ConvertFromUrl(URL)
1815 _PropertyGet = Title
1817 _PropertyGet = _Type
1818 Case UCase("OnCreate"), UCase("OnFocus"), UCase("OnLoad"), UCase("OnLoadFinished"), UCase("OnModifyChanged") _
1819 , UCase("OnNew"), UCase("OnPrepareUnload"), UCase("OnPrepareViewClosing"), UCase("OnSave"), UCase("OnSaveAs") _
1820 , UCase("OnSaveAsDone"), UCase("OnSaveAsFailed"), UCase("OnSaveDone"), UCase("OnSaveFailed"), UCase("OnSaveTo") _
1821 , UCase("OnSaveToDone"), UCase("OnSaveToFailed"), UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") _
1822 , UCase("OnTitleChanged"), UCase("OnUnfocus"), UCase("OnUnload"), UCase("OnViewClosed"), UCase("OnViewCreated")
1823 ' Find script event
1824 sEvent = ""
1825 If IsNull(Document) Then vEvents = Array() Else vEvents = Document.getEvents().ElementNames ' Returns an array
1826 For i = 0 To UBound(vEvents)
1827 If UCase(vEvents(i)) = UCase(psProperty) Then
1828 sEvent = vEvents(i)
1829 Exit For
1830 End If
1831 Next i
1832 If sEvent = "" Then
1833 _PropertyGet = ""
1834 Else
1835 vEvent = Document.getEvents().getByName(sEvent)
1836 If IsEmpty(vEvent) Then
1837 _PropertyGet = ""
1839 _PropertyGet = ""
1840 Else
1841 _PropertyGet = vEvent(1).Value
1842 End If
1843 End If
1845 _PropertyGet = MetaData.getDatabaseProductName() & " " & MetaData.getDatabaseProductVersion
1846 Case Else
1847 Goto Trace_Error
1848 End Select
1850 Exit_Function:
1852 Exit Function
1853 Trace_Error:
1854 TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
1855 _PropertyGet = EMPTY
1856 Goto Exit_Function
1857 Error_Function:
1859 _PropertyGet = EMPTY
1860 GoTo Exit_Function
1861 End Function ' _PropertyGet
1863 REM -----------------------------------------------------------------------------------------------------------------------
1864 Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
1865 ' Returns psSql after substitution of [] by quote character
1866 ' [] square brackets in (single) quoted strings not affected
1868 Dim sQuote As String 'RDBMS specific quote character
1869 Dim vSubStrings() As Variant, i As Integer
1870 Const cstSingleQuote = "'"
1872 sQuote = MetaData.IdentifierQuoteString
1873 If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported.
1874 _ReplaceSquareBrackets = Trim(psSql)
1875 Exit Function
1876 End If
1877 vSubStrings() = Split(psSql, cstSingleQuote)
1878 For i = 0 To UBound(vSubStrings)
1879 If (i Mod 2) = 0 Or (i = UBound(vSubStrings)) Then ' Only even substrings are parsed for square brackets. Last substring is parsed anyway
1882 End If
1883 Next i
1885 _ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote))
1889 </script:module>