| blob | 109d4c57d909d6cd08201e32f6febcc88915245a |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Database" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === The SFDatabases library is one of the associated libraries. ===
6 REM === Full documentation is available on https://help.libreoffice.org/ ===
7 REM =======================================================================================================================
9 Option Compatible
10 Option ClassModule
12 Option Explicit
14 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
15 ''' SF_Database
16 ''' ===========
17 ''' Management of databases embedded in or related to Base documents
18 ''' Each instance of the current class represents a single database, with essentially its tables, queries and data
19 '''
20 ''' The exchanges with the database are done in SQL only.
21 ''' To make them more readable, use optionally square brackets to surround table/query/field names
22 ''' instead of the (RDBMS-dependent) normal surrounding character (usually, double-quote, single-quote or other).
23 ''' SQL statements may be run in direct or indirect mode. In direct mode the statement is transferred literally
24 ''' without syntax checking nor review to the database system.
25 '''
26 ''' The provided interfaces include simple tables, queries and fields lists, and access to database metadata.
27 '''
28 ''' Service invocation and usage:
30 ''' Dim myDatabase As Object
31 ''' Set myDatabase = CreateScriptService("SFDatabases.Database", FileName, , [ReadOnly], [User, [Password]])
32 ''' ' Args:
33 ''' ' FileName: the name of the Base file compliant with the SF_FileSystem.FileNaming notation
34 ''' ' RegistrationName: the name of a registered database (mutually exclusive with FileName)
35 ''' ' ReadOnly: Default = True
36 ''' ' User, Password: additional connection arguments to the database server
37 ''' ' ... Run queries, SQL statements, ...
38 ''' myDatabase.CloseDatabase()
39 '''
41 ''' Dim myDoc As Object, myDatabase As Object, ui As Object
44 ''' Set myDatabase = myDoc.GetDatabase() ' user and password are supplied here, if needed
45 ''' ' ... Run queries, SQL statements, ...
46 ''' myDoc.CloseDocument()
47 '''
48 ''' Detailed user documentation:
49 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_database.html?DbPAR=BASIC
50 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
52 REM ================================================================== EXCEPTIONS
57 REM ============================================================= PRIVATE MEMBERS
59 Private [Me] As Object
60 Private [_Parent] As Object
61 Private ObjectType As String ' Must be DATABASE
62 Private ServiceName As String
63 Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource
64 Private _Connection As Object ' com.sun.star.sdbc.XConnection
65 Private _URL As String ' Text on status bar
66 Private _Location As String ' File name
67 Private _ReadOnly As Boolean
68 Private _MetaData As Object ' com.sun.star.sdbc.XDatabaseMetaData
70 REM ============================================================ MODULE CONSTANTS
74 REM ===================================================== CONSTRUCTOR/DESTRUCTOR
76 REM -----------------------------------------------------------------------------
77 Private Sub Class_Initialize()
78 Set [Me] = Nothing
79 Set [_Parent] = Nothing
82 Set _DataSource = Nothing
83 Set _Connection = Nothing
84 _URL = ""
85 _Location = ""
86 _ReadOnly = True
87 Set _MetaData = Nothing
88 End Sub ' SFDatabases.SF_Database Constructor
90 REM -----------------------------------------------------------------------------
91 Private Sub Class_Terminate()
92 Call Class_Initialize()
93 End Sub ' SFDatabases.SF_Database Destructor
95 REM -----------------------------------------------------------------------------
96 Public Function Dispose() As Variant
97 Call Class_Terminate()
98 Set Dispose = Nothing
99 End Function ' SFDatabases.SF_Database Explicit Destructor
101 REM ================================================================== PROPERTIES
103 REM -----------------------------------------------------------------------------
104 Property Get Queries() As Variant
105 ''' Return the list of available queries in the database
107 End Property ' SFDatabases.SF_Database.Queries (get)
109 REM -----------------------------------------------------------------------------
110 Property Get Tables() As Variant
111 ''' Return the list of available Tables in the database
113 End Property ' SFDatabases.SF_Database.Tables (get)
115 REM -----------------------------------------------------------------------------
116 Property Get XConnection() As Variant
117 ''' Return a com.sun.star.sdbc.XConnection UNO object
119 End Property ' SFDatabases.SF_Database.XConnection (get)
121 REM -----------------------------------------------------------------------------
122 Property Get XMetaData() As Variant
123 ''' Return a com.sun.star.sdbc.XDatabaseMetaData UNO object
125 End Property ' SFDatabases.SF_Database.XMetaData (get)
127 REM ===================================================================== METHODS
129 REM -----------------------------------------------------------------------------
130 Public Sub CloseDatabase()
131 ''' Close the current database connection
134 Const cstSubArgs = ""
138 Check:
139 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
141 Try:
142 With _Connection
143 If Not IsNull(_Connection) Then
145 .close()
146 .dispose()
147 End If
148 Dispose()
149 End With
151 Finally:
152 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
153 Exit Sub
154 End Sub
156 REM -----------------------------------------------------------------------------
157 Public Function DAvg(Optional ByVal Expression As Variant _
158 , Optional ByVal TableName As Variant _
159 , Optional ByVal Criteria As Variant _
160 ) As Variant
161 ''' Compute the aggregate function AVG() on a field or expression belonging to a table
162 ''' filtered by a WHERE-clause.
163 ''' Args:
164 ''' Expression: an SQL expression
165 ''' TableName: the name of a table
166 ''' Criteria: an optional WHERE clause without the word WHERE
170 End Function ' SFDatabases.SF_Database.DAvg
172 REM -----------------------------------------------------------------------------
173 Public Function DCount(Optional ByVal Expression As Variant _
174 , Optional ByVal TableName As Variant _
175 , Optional ByVal Criteria As Variant _
176 ) As Variant
177 ''' Compute the aggregate function COUNT() on a field or expression belonging to a table
178 ''' filtered by a WHERE-clause.
179 ''' Args:
180 ''' Expression: an SQL expression
181 ''' TableName: the name of a table
182 ''' Criteria: an optional WHERE clause without the word WHERE
186 End Function ' SFDatabases.SF_Database.DCount
188 REM -----------------------------------------------------------------------------
189 Public Function DLookup(Optional ByVal Expression As Variant _
190 , Optional ByVal TableName As Variant _
191 , Optional ByVal Criteria As Variant _
192 , Optional ByVal OrderClause As Variant _
193 ) As Variant
194 ''' Compute the aggregate function Lookup() on a field or expression belonging to a table
195 ''' filtered by a WHERE-clause.
196 ''' To order the results, a pvOrderClause may be precised. The 1st record will be retained.
197 ''' Args:
198 ''' Expression: an SQL expression
199 ''' TableName: the name of a table
200 ''' Criteria: an optional WHERE clause without the word WHERE
205 End Function ' SFDatabases.SF_Database.DLookup
207 REM -----------------------------------------------------------------------------
208 Public Function DMax(Optional ByVal Expression As Variant _
209 , Optional ByVal TableName As Variant _
210 , Optional ByVal Criteria As Variant _
211 ) As Variant
212 ''' Compute the aggregate function MAX() on a field or expression belonging to a table
213 ''' filtered by a WHERE-clause.
214 ''' Args:
215 ''' Expression: an SQL expression
216 ''' TableName: the name of a table
217 ''' Criteria: an optional WHERE clause without the word WHERE
221 End Function ' SFDatabases.SF_Database.DMax
223 REM -----------------------------------------------------------------------------
224 Public Function DMin(Optional ByVal Expression As Variant _
225 , Optional ByVal TableName As Variant _
226 , Optional ByVal Criteria As Variant _
227 ) As Variant
228 ''' Compute the aggregate function MIN() on a field or expression belonging to a table
229 ''' filtered by a WHERE-clause.
230 ''' Args:
231 ''' Expression: an SQL expression
232 ''' TableName: the name of a table
233 ''' Criteria: an optional WHERE clause without the word WHERE
237 End Function ' SFDatabases.SF_Database.DMin
239 REM -----------------------------------------------------------------------------
240 Public Function DSum(Optional ByVal Expression As Variant _
241 , Optional ByVal TableName As Variant _
242 , Optional ByVal Criteria As Variant _
243 ) As Variant
244 ''' Compute the aggregate function Sum() on a field or expression belonging to a table
245 ''' filtered by a WHERE-clause.
246 ''' Args:
247 ''' Expression: an SQL expression
248 ''' TableName: the name of a table
249 ''' Criteria: an optional WHERE clause without the word WHERE
253 End Function ' SFDatabases.SF_Database.DSum
255 REM -----------------------------------------------------------------------------
256 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
257 ''' Return the actual value of the given property
258 ''' Args:
259 ''' PropertyName: the name of the property as a string
260 ''' Returns:
261 ''' The actual value of the property
262 ''' Exceptions:
263 ''' ARGUMENTERROR The property does not exist
264 ''' Examples:
268 Const cstSubArgs = ""
270 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
271 GetProperty = Null
273 Check:
274 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
275 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
276 End If
278 Try:
279 GetProperty = _PropertyGet(PropertyName)
281 Finally:
282 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
283 Exit Function
284 Catch:
285 GoTo Finally
286 End Function ' SFDatabases.SF_Database.GetProperty
288 REM -----------------------------------------------------------------------------
289 Public Function GetRows(Optional ByVal SQLCommand As Variant _
290 , Optional ByVal DirectSQL As Variant _
291 , Optional ByVal Header As Variant _
292 , Optional ByVal MaxRows As Variant _
293 ) As Variant
294 ''' Return the content of a table, a query or a SELECT SQL statement as an array
295 ''' Args:
296 ''' SQLCommand: a table name, a query name or a SELECT SQL statement
297 ''' DirectSQL: when True, no syntax conversion is done by LO. Default = False
298 ''' Ignored when SQLCommand is a table or a query name
299 ''' Header: When True, a header row is inserted on the top of the array with the column names. Default = False
300 ''' MaxRows: The maximum number of returned rows. If absent, all records are returned
301 ''' Returns:
303 ''' an empty array if no records returned
304 ''' Example:
305 ''' Dim a As Variant
306 ''' a = myDatabase.GetRows("SELECT [First Name], [Last Name] FROM [Employees] ORDER BY [Last Name]", Header := True)
308 Dim vResult As Variant ' Return value
309 Dim oResult As Object ' com.sun.star.sdbc.XResultSet
310 Dim oQuery As Object ' com.sun.star.ucb.XContent
311 Dim sSql As String ' SQL statement
312 Dim bDirect ' Alias of DirectSQL
313 Dim lCols As Long ' Number of columns
314 Dim lRows As Long ' Number of rows
315 Dim oColumns As Object ' Collection of com.sun.star.sdb.ODataColumn
316 Dim bRead As Boolean ' When True, next record has been read successfully
317 Dim i As Long
321 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
322 vResult = Array()
324 Check:
325 If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False
326 If IsMissing(Header) Or IsEmpty(Header) Then Header = False
327 If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0
328 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
329 If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally
330 If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally
331 If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally
332 If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally
333 End If
335 Try:
336 ' Table, query of SQL ? Prepare resultset
337 If ScriptForge.SF_Array.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
339 bDirect = True
340 ElseIf ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
341 Set oQuery = _Connection.Queries.getByName(SQLCommand)
342 sSql = oQuery.Command
343 bDirect = Not oQuery.EscapeProcessing
344 ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then
345 sSql = SQLCommand
346 bDirect = DirectSQL
347 Else
348 GoTo Finally
349 End If
351 ' Execute command
352 Set oResult = _ExecuteSql(sSql, bDirect)
353 If IsNull(oResult) Then GoTo Finally
355 With oResult
356 'Initialize output array with header row
357 Set oColumns = oResult.getColumns()
358 lCols = oColumns.Count - 1
359 If Header Then
360 lRows = 0
362 For i = 0 To lCols
363 vResult(lRows, i) = oColumns.getByIndex(i).Name
364 Next i
366 Else
367 lRows = -1
368 End If
370 ' Load data
371 bRead = .first()
373 lRows = lRows + 1
374 If lRows = 0 Then
376 Else
378 End If
379 For i = 0 To lCols
380 vResult(lRows, i) = _GetColumnValue(oResult, i + 1)
381 Next i
382 bRead = .next()
383 Loop
384 End With
386 Finally:
387 GetRows = vResult
388 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
389 Exit Function
390 Catch:
391 GoTo Finally
392 End Function ' SFDatabases.SF_Database.GetRows
394 REM -----------------------------------------------------------------------------
395 Public Function Methods() As Variant
396 ''' Return the list of public methods of the Database service as an array
398 Methods = Array( _
412 )
414 End Function ' SFDatabases.SF_Database.Methods
416 REM -----------------------------------------------------------------------------
417 Public Function OpenFormDocument(Optional ByVal FormDocument As Variant) As Object
418 ''' Open the FormDocument given by its hierarchical name in normal mode
419 ''' If the form document is already open, the form document is made active
420 ''' Args:
421 ''' FormDocument: a valid form document name as a case-sensitive string
422 ''' When hierarchical, the hierarchy must be rendered with forward slashes ("/")
423 ''' Returns:
424 ''' A FormDocument instance or Nothing
425 ''' Exceptions:
426 ''' Form name is invalid
427 ''' Example:
430 Dim oOpen As Object ' Return value
431 Dim oFormDocuments As Variant ' com.sun.star.comp.dba.ODocumentContainer
432 Dim vFormNames As Variant ' Array of all document form names present in the document
433 Dim vOpenArgs As Variant ' Array of property values
434 Dim oNewForm As Object ' Output of loadComponent()
438 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
439 Set oOpen = Nothing
441 Check:
442 ' Build list of available FormDocuments recursively with _CollectFormDocuments
443 Set oFormDocuments = _Connection.Parent.DataBaseDocument.FormDocuments
445 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
446 vFormNames = Split(_CollectFormDocuments(oFormDocuments), cstToken)
447 If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally
448 End If
450 Try:
453 )
456 Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDocuments.FormDocument", oNewForm)
458 ' Prevent desynchonization when using .last(), .next() etc immediately after component loading. Bug #156836
459 Wait 1
461 Finally:
462 Set OpenFormDocument = oOpen
463 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
464 Exit Function
465 Catch:
466 GoTo Finally
467 End Function ' SF_Databases.SF_Database.OpenFormDocument
469 REM -----------------------------------------------------------------------------
470 Public Function OpenQuery(Optional ByVal QueryName As Variant) As Object
471 ''' Open the query given by its name
472 ''' The datasheet will live independently from any other (typically Base) component
473 ''' Args:
474 ''' QueryName: a valid query name as a case-sensitive string
475 ''' Returns:
476 ''' A Datasheet class instance if the query could be opened, otherwise Nothing
477 ''' Exceptions:
478 ''' Query name is invalid
479 ''' Example:
482 Dim oOpen As Object ' Return value
486 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
487 Set oOpen = Nothing
489 Check:
490 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
491 If Not ScriptForge.SF_Utils._Validate(QueryName, "QueryName", V_STRING, Queries) Then GoTo Finally
492 End If
494 Try:
495 Set oOpen = _OpenDatasheet(QueryName, com.sun.star.sdb.CommandType.QUERY _
496 , _Connection.Queries.getByName(QueryName).EscapeProcessing)
498 Finally:
499 Set OpenQuery = oOpen
500 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
501 Exit Function
502 Catch:
503 GoTo Finally
504 End Function ' SFDocuments.SF_Base.OpenQuery
506 REM -----------------------------------------------------------------------------
507 Public Function OpenSql(Optional ByRef Sql As Variant _
508 , Optional ByVal DirectSql As Variant _
509 ) As Object
510 ''' Open the datasheet based on a SQL SELECT statement.
511 ''' The datasheet will live independently from any other (typically Base) component
512 ''' Args:
513 ''' Sql: a valid Sql statement as a case-sensitive string.
514 ''' Identifiers may be surrounded by square brackets
515 ''' DirectSql: when True, the statement is processed by the targeted RDBMS
516 ''' Returns:
517 ''' A Datasheet class instance if it could be opened, otherwise Nothing
518 ''' Example:
521 Dim oOpen As Object ' Return value
525 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
526 Set oOpen = Nothing
528 Check:
529 If IsMissing(DirectSql) Or IsEmpty(DirectSql) Then DirectSql = False
530 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
532 If Not ScriptForge.SF_Utils._Validate(DirectSql, "DirectSql", ScriptForge.V_BOOLEAN) Then GoTo Finally
533 End If
535 Try:
536 Set oOpen = _OpenDatasheet(_ReplaceSquareBrackets(Sql), com.sun.star.sdb.CommandType.COMMAND, Not DirectSql)
538 Finally:
539 Set OpenSql = oOpen
540 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
541 Exit Function
542 Catch:
543 GoTo Finally
544 End Function ' SFDocuments.SF_Base.OpenSql
546 REM -----------------------------------------------------------------------------
547 Public Function OpenTable(Optional ByVal TableName As Variant) As Object
548 ''' Open the table given by its name
549 ''' The datasheet will live independently from any other (typically Base) component
550 ''' Args:
551 ''' TableName: a valid table name as a case-sensitive string
552 ''' Returns:
553 ''' A Datasheet class instance if the table could be opened, otherwise Nothing
554 ''' Exceptions:
555 ''' Table name is invalid
556 ''' Example:
559 Dim oOpen As Object ' Return value
563 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
564 Set oOpen = Nothing
566 Check:
567 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
568 If Not ScriptForge.SF_Utils._Validate(TableName, "TableName", V_STRING, Tables) Then GoTo Finally
569 End If
571 Try:
572 Set oOpen = _OpenDatasheet(TableName, com.sun.star.sdb.CommandType.TABLE, True)
574 Finally:
575 Set OpenTable = oOpen
576 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
577 Exit Function
578 Catch:
579 GoTo Finally
580 End Function ' SFDocuments.SF_Base.OpenTable
582 REM -----------------------------------------------------------------------------
583 Public Function Properties() As Variant
584 ''' Return the list or properties of the Database class as an array
586 Properties = Array( _
591 )
593 End Function ' SFDatabases.SF_Database.Properties
595 REM -----------------------------------------------------------------------------
596 Public Function RunSql(Optional ByVal SQLCommand As Variant _
597 , Optional ByVal DirectSQL As Variant _
598 ) As Boolean
599 ''' Execute an action query (table creation, record insertion, ...) or SQL statement on the current database
600 ''' Args:
601 ''' SQLCommand: a query name or an SQL statement
602 ''' DirectSQL: when True, no syntax conversion is done by LO. Default = False
603 ''' Ignored when SQLCommand is a query name
604 ''' Exceptions:
605 ''' DBREADONLYERROR The method is not applicable on a read-only database
606 ''' Example:
607 ''' myDatabase.RunSql("INSERT INTO [EMPLOYEES] VALUES(25, 'SMITH', 'John')", DirectSQL := True)
609 Dim bResult As Boolean ' Return value
610 Dim oStatement As Object ' com.sun.star.sdbc.XStatement
611 Dim oQuery As Object ' com.sun.star.ucb.XContent
612 Dim sSql As String ' SQL statement
613 Dim bDirect ' Alias of DirectSQL
618 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
619 bResult = False
621 Check:
622 If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False
623 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
624 If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally
625 If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally
626 End If
627 If _ReadOnly Then GoTo Catch_ReadOnly
629 Try:
630 ' Query of SQL ?
631 If ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
632 Set oQuery = _Connection.Queries.getByName(SQLCommand)
633 sSql = oQuery.Command
634 bDirect = Not oQuery.EscapeProcessing
635 ElseIf Not ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then
636 sSql = SQLCommand
637 bDirect = DirectSQL
638 Else
639 GoTo Finally
640 End If
642 ' Execute command
643 bResult = _ExecuteSql(sSql, bDirect)
645 Finally:
646 RunSql = bResult
647 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
648 Exit Function
649 Catch:
650 GoTo Finally
651 Catch_ReadOnly:
652 ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR)
653 GoTo Finally
654 End Function ' SFDatabases.SF_Database.RunSql
656 REM -----------------------------------------------------------------------------
657 Public Function SetProperty(Optional ByVal PropertyName As Variant _
658 , Optional ByRef Value As Variant _
659 ) As Boolean
660 ''' Set a new value to the given property
661 ''' Args:
662 ''' PropertyName: the name of the property as a string
663 ''' Value: its new value
664 ''' Exceptions
665 ''' ARGUMENTERROR The property does not exist
670 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
671 SetProperty = False
673 Check:
674 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
675 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
676 End If
678 Try:
679 Select Case UCase(PropertyName)
680 Case Else
681 End Select
683 Finally:
684 SF_Utils._ExitFunction(cstThisSub)
685 Exit Function
686 Catch:
687 GoTo Finally
688 End Function ' SFDatabases.SF_Database.SetProperty
690 REM =========================================================== PRIVATE FUNCTIONS
692 REM -----------------------------------------------------------------------------
693 Private Function _CollectFormDocuments(ByRef poContainer As Object) As String
694 ''' Returns a token-separated string of all hierarchical formdocument names
695 ''' depending on the formdocuments container in argument
696 ''' The function traverses recursively the whole tree below the container
697 ''' The initial call starts from the container _Component.getFormDocuments
698 ''' The list contains closed and open forms
700 Dim sCollectNames As String ' Return value
701 Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form)
702 Dim i As Long
704 ' Identifies forms. Folders have a zero-length content type
706 On Local Error GoTo Finally
708 Try:
709 sCollectNames = ""
710 With poContainer
712 Set oSubItem = .getByIndex(i)
713 If oSubItem.ContentType = cstFormType Then ' Add the form to the list
715 Else
717 End If
718 Next i
719 End With
721 Finally:
724 Else
725 _CollectFormDocuments = ""
726 End If
727 Exit Function
728 End Function ' SFDocuments.SF_Base._CollectFormDocuments
730 REM -----------------------------------------------------------------------------------------------------------------------
731 Private Function _DFunction(ByVal psFunction As String _
732 , Optional ByVal pvExpression As Variant _
733 , Optional ByVal pvTableName As Variant _
734 , Optional ByVal pvCriteria As Variant _
735 , Optional ByVal pvOrderClause As Variant _
736 ) As Variant
737 ''' Build and execute a SQL statement computing the aggregate function psFunction
738 ''' on a field or expression pvExpression belonging to a table pvTableName
739 ''' filtered by a WHERE-clause pvCriteria.
740 ''' To order the results, a pvOrderClause may be precised.
742 ''' Args:
743 ''' psFunction an optional aggregate function: SUM, COUNT, AVG, LOOKUP
744 ''' pvExpression: an SQL expression
745 ''' pvTableName: the name of a table, NOT surrounded with quoting char
746 ''' pvCriteria: an optional WHERE clause without the word WHERE
748 ''' (meaningful only for LOOKUP)
750 Dim vResult As Variant ' Return value
751 Dim oResult As Object ' com.sun.star.sdbc.XResultSet
752 Dim sSql As String ' SQL statement.
753 Dim sExpr As String ' For inclusion of aggregate function
754 Dim sTarget as String ' Alias of pvExpression
755 Dim sWhere As String ' Alias of pvCriteria
756 Dim sOrderBy As String ' Alias of pvOrderClause
758 Dim sProductName As String ' RDBMS as a string
759 Const cstAliasField = "[" & "TMP_ALIAS_ANY_FIELD" & "]" ' Alias field in SQL expression
761 Const cstSubArgs = "Expression, TableName, [Criteria=""""], [OrderClause=""""]"
764 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
765 vResult = Null
767 Check:
768 If IsMissing(pvCriteria) Or IsEmpty(pvCriteria) Then pvCriteria = ""
769 If IsMissing(pvOrderClause) Or IsEmpty(pvOrderClause) Then pvOrderClause = ""
770 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
771 If Not ScriptForge.SF_Utils._Validate(pvExpression, "Expression", V_STRING) Then GoTo Finally
772 If Not ScriptForge.SF_Utils._Validate(pvTableName, "TableName", V_STRING, Tables) Then GoTo Finally
773 If Not ScriptForge.SF_Utils._Validate(pvCriteria, "Criteria", V_STRING) Then GoTo Finally
774 If Not ScriptForge.SF_Utils._Validate(pvOrderClause, "OrderClause", V_STRING) Then GoTo Finally
775 End If
777 Try:
778 If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
779 If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
780 sLimit = ""
784 sProductName = UCase(_MetaData.getDatabaseProductName())
786 Select Case sProductName
788 If psFunction = cstLookup Then
789 sTarget = pvExpression
791 Else
793 End If
794 sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & psTableName & sWhere & sOrderBy & sLimit
796 If psFunction = cstLookup Then sTarget = "FIRST 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")"
797 sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy
798 Case Else ' Standard syntax - Includes HSQLDB
799 If psFunction = cstLookup Then sTarget = "TOP 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")"
800 sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy
801 End Select
803 ' Execute the SQL statement and retain the first column of the first record
804 Set oResult = _ExecuteSql(sSql, True)
805 If Not IsNull(oResult) And Not IsEmpty(oResult) Then
806 If Not oResult.first() Then Goto Finally
807 If oResult.isAfterLast() Then GoTo Finally
809 End If
810 Set oResult = Nothing
812 Finally:
813 _DFunction = vResult
814 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
815 Exit Function
816 Catch:
817 GoTo Finally
818 End Function ' SFDatabases.SF_Database._DFunction
820 REM -----------------------------------------------------------------------------
821 Private Function _ExecuteSql(ByVal psSql As String _
822 , ByVal pbDirect As Boolean _
823 ) As Variant
824 ''' Return a read-only Resultset based on a SELECT SQL statement or execute the given action SQL (INSERT, CREATE TABLE, ...)
825 ''' The method raises a fatal error when the SQL statement cannot be interpreted
826 ''' Args:
827 ''' psSql : the SQL statement. Square brackets are replaced by the correct field surrounding character
828 ''' pbDirect: when True, no syntax conversion is done by LO. Default = False
829 ''' Exceptions
830 ''' SQLSYNTAXERROR The given SQL statement is incorrect
832 Dim vResult As Variant ' Return value - com.sun.star.sdbc.XResultSet or Boolean
833 Dim oStatement As Object ' com.sun.star.sdbc.XStatement
834 Dim sSql As String ' Alias of psSql
835 Dim bSelect As Boolean ' True when SELECT statement
836 Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements
838 Set vResult = Nothing
839 bErrorHandler = ScriptForge.SF_Utils._ErrorHandling()
840 If bErrorHandler Then On Local Error GoTo Catch
842 Try:
843 sSql = _ReplaceSquareBrackets(psSql)
846 Set oStatement = _Connection.createStatement()
847 With oStatement
848 If bSelect Then
849 .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
850 .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
851 End If
852 .EscapeProcessing = Not pbDirect
854 ' Setup the result set
855 If bErrorHandler Then On Local Error GoTo Catch_Sql
856 If bSelect Then Set vResult = .executeQuery(sSql) Else vResult = .execute(sSql)
857 End With
859 Finally:
860 _ExecuteSql = vResult
861 Set oStatement = Nothing
862 Exit Function
863 Catch_Sql:
864 ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAXERROR, sSql)
865 GoTo Finally
866 Catch:
867 GoTo Finally
868 End Function ' SFDatabases.SF_Database._ExecuteSql
870 REM -----------------------------------------------------------------------------
871 Private Function _GetColumnValue(ByRef poResultSet As Object _
872 , ByVal plColIndex As Long _
873 , Optional ByVal pbReturnBinary As Boolean _
874 ) As Variant
875 ''' Get the data stored in the current record of a result set in a given column
877 ''' Args:
878 ''' poResultSet: com.sun.star.sdbc.XResultSet or com.sun.star.awt.XTabControllerModel
880 ''' pbReturnBinary: when True, the method returns the content of a binary field,
881 ''' as long as its length does not exceed a maximum length.
882 ''' Default = False: binary fields are not returned, only their length
883 ''' Returns:
884 ''' The Variant value found in the column
885 ''' Dates and times are returned as Basic dates
886 ''' Null values are returned as Null
887 ''' Errors or strange data types are returned as Null as well
889 Dim vValue As Variant ' Return value
890 Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType
891 Dim vDateTime As Variant ' com.sun.star.util.DateTime
892 Dim oStream As Object ' Long character or binary streams
893 Dim bNullable As Boolean ' The field is defined as accepting Null values
894 Dim lSize As Long ' Binary field length
899 vValue = Empty ' Default value if error
900 If IsMissing(pbReturnBinary) Then pbReturnBinary = False
902 With com.sun.star.sdbc.DataType
903 lType = poResultSet.MetaData.getColumnType(plColIndex)
904 bNullable = ( poResultSet.MetaData.IsNullable(plColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
906 Select Case lType
907 Case .ARRAY : vValue = poResultSet.getArray(plColIndex)
908 Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
909 Set oStream = poResultSet.getBinaryStream(plColIndex)
910 If bNullable Then
911 If Not poResultSet.wasNull() Then
912 If Not ScriptForge.SF_Session.HasUNOMethod(oStream, "getLength") Then ' When no recordset
913 lSize = cstMaxBinLength
914 Else
915 lSize = CLng(oStream.getLength())
916 End If
917 If lSize <= cstMaxBinLength And pbReturnBinary Then
918 vValue = Array()
919 oStream.readBytes(vValue, lSize)
920 Else ' Return length of field, not content
921 vValue = lSize
922 End If
923 End If
924 End If
925 If Not IsNull(oStream) Then oStream.closeInput()
926 Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(plColIndex)
927 Case .DATE
928 vDateTime = poResultSet.getDate(plColIndex)
929 If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
930 Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
931 vValue = Null
932 Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(plColIndex)
933 Case .FLOAT : vValue = poResultSet.getFloat(plColIndex)
934 Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(plColIndex)
935 Case .BIGINT : vValue = CLng(poResultSet.getLong(plColIndex))
936 Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(plColIndex)
937 Case .SQLNULL : vValue = poResultSet.getNull(plColIndex)
938 Case .OBJECT, .OTHER, .STRUCT : vValue = Null
939 Case .REF : vValue = poResultSet.getRef(plColIndex)
940 Case .TINYINT : vValue = poResultSet.getShort(plColIndex)
941 Case .CHAR, .VARCHAR : vValue = poResultSet.getString(plColIndex)
942 Case .LONGVARCHAR, .CLOB
943 If bNullable Then
944 If Not poResultSet.wasNull() Then vValue = poResultSet.getString(plColIndex)
945 Else
946 vValue = ""
947 End If
948 Case .TIME
949 vDateTime = poResultSet.getTime(plColIndex)
950 If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
951 Case .TIMESTAMP
952 vDateTime = poResultSet.getTimeStamp(plColIndex)
953 If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
954 + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
955 Case Else
956 vValue = poResultSet.getString(plColIndex) 'GIVE STRING A TRY
957 If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
958 End Select
959 If bNullable Then
960 If poResultSet.wasNull() Then vValue = Null
961 End If
962 End With
964 _GetColumnValue = vValue
966 End Function ' SFDatabases.SF_Database.GetColumnValue
968 REM -----------------------------------------------------------------------------
969 Public Function _OpenDatasheet(Optional ByVal psCommand As Variant _
970 , piDatasheetType As Integer _
971 , pbEscapeProcessing As Boolean _
972 ) As Object
973 ''' Open the datasheet given by its name and its type
974 ''' The datasheet will live independently from any other component
975 ''' Args:
976 ''' psCommand: a valid table or query name or an SQL statement as a case-sensitive string
977 ''' piDatasheetType: one of the com.sun.star.sdb.CommandType constants
978 ''' pbEscapeProcessing: == Not DirectSql
979 ''' Returns:
980 ''' A Datasheet class instance if the datasheet could be opened, otherwise Nothing
982 Dim oOpen As Object ' Return value
983 Dim oNewDatasheet As Object ' com.sun.star.lang.XComponent
984 Dim oURL As Object ' com.sun.star.util.URL
985 Dim oDispatch As Object ' com.sun.star.frame.XDispatch
986 Dim vArgs As Variant ' Array of property values
988 On Local Error GoTo Catch
989 Set oOpen = Nothing
991 Try:
992 ' Setup the dispatcher
993 Set oURL = New com.sun.star.util.URL
995 Set oDispatch = StarDesktop.queryDispatch(oURL, "_blank", com.sun.star.frame.FrameSearchFlag.CREATE)
997 ' Setup the arguments of the component to create
998 With ScriptForge.SF_Utils
999 vArgs = Array( _
1009 )
1010 End With
1012 ' Open the targeted datasheet
1013 Set oNewDatasheet = oDispatch.dispatchWithReturnValue(oURL, vArgs)
1014 If Not IsNull(oNewDatasheet) Then Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Datasheet", oNewDatasheet, [Me])
1016 Finally:
1017 Set _OpenDatasheet = oOpen
1018 Exit Function
1019 Catch:
1020 GoTo Finally
1021 End Function ' SFDocuments.SF_Base._OpenDatasheet
1023 REM -----------------------------------------------------------------------------
1024 Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
1025 ''' Return the value of the named property
1026 ''' Args:
1027 ''' psProperty: the name of the property
1029 Dim cstThisSub As String
1030 Const cstSubArgs = ""
1033 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1035 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
1037 Select Case psProperty
1039 If Not IsNull(_Connection) Then _PropertyGet = _Connection.Queries.getElementNames() Else _PropertyGet = Array()
1041 If Not IsNull(_Connection) Then _PropertyGet = _Connection.Tables.getElementNames() Else _PropertyGet = Array()
1043 Set _PropertyGet = _Connection
1045 Set _PropertyGet = _MetaData
1046 Case Else
1047 _PropertyGet = Null
1048 End Select
1050 Finally:
1051 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1052 Exit Function
1053 Catch:
1054 GoTo Finally
1055 End Function ' SFDatabases.SF_Database._PropertyGet
1057 REM -----------------------------------------------------------------------------
1058 Private Function _ReplaceSquareBrackets(ByVal psSql As String) As String
1059 ''' Returns the input SQL command after replacement of square brackets by the table/field names quoting character
1061 Dim sSql As String ' Return value
1062 Dim sQuote As String ' RDBMS specific table/field surrounding character
1063 Dim sConstQuote As String ' Delimiter for string constants in SQL - usually the single quote
1066 Try:
1067 sQuote = _MetaData.IdentifierQuoteString
1068 sConstQuote = Iif(sQuote = cstSingle, cstDouble, cstSingle)
1070 ' Replace the square brackets
1074 Finally:
1075 _ReplaceSquareBrackets = sSql
1076 Exit Function
1077 End Function ' SFDatabases.SF_Database._ReplaceSquareBrackets
1079 REM -----------------------------------------------------------------------------
1080 Private Function _Repr() As String
1081 ''' Convert the Database instance to a readable string, typically for debugging purposes (DebugPrint ...)
1082 ''' Args:
1083 ''' Return:
1086 _Repr = "[DATABASE]: " & _Location & " (" & _URL & ")"
1088 End Function ' SFDatabases.SF_Database._Repr
1090 REM ============================================ END OF SFDATABASES.SF_DATABASE
1091 </script:module>