diff options
Diffstat (limited to 'wizards/source/sfdatabases/SF_Database.xba')
| -rw-r--r-- | wizards/source/sfdatabases/SF_Database.xba | 1475 |
1 files changed, 1475 insertions, 0 deletions
diff --git a/wizards/source/sfdatabases/SF_Database.xba b/wizards/source/sfdatabases/SF_Database.xba new file mode 100644 index 0000000000..ff0eafc5b7 --- /dev/null +++ b/wizards/source/sfdatabases/SF_Database.xba @@ -0,0 +1,1475 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Database" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDatabases library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Database +''' =========== +''' Management of databases embedded in or related to Base documents +''' Each instance of the current class represents a single database, with essentially its tables, queries and data +''' +''' The exchanges with the database are done in SQL only. +''' To make them more readable, use optionally square brackets to surround table/query/field names +''' instead of the (RDBMS-dependent) normal surrounding character (usually, double-quote, single-quote or other). +''' SQL statements may be run in direct or indirect mode. In direct mode the statement is transferred literally +''' without syntax checking nor review to the database system. +''' +''' The provided interfaces include simple tables, queries and fields lists, and access to database metadata. +''' +''' Transaction handling +''' Changes to data remain reversible until the moment the running script instructs the database to commit them. +''' The implicit (default) behaviour is that commit takes place after the execution of every single SQL statement. +''' The choice can be made (SetTransactionMode()) to take commitments manually. +''' The Commit() and Rollback() statements delimit transactions. +''' +''' Service invocation and usage: +''' 1) To access any database at anytime +''' Dim myDatabase As Object +''' Set myDatabase = CreateScriptService("SFDatabases.Database", FileName, , [ReadOnly], [User, [Password]]) +''' ' Args: +''' ' FileName: the name of the Base file compliant with the SF_FileSystem.FileNaming notation +''' ' RegistrationName: the name of a registered database (mutually exclusive with FileName) +''' ' ReadOnly: Default = True +''' ' User, Password: additional connection arguments to the database server +''' ' ... Run queries, SQL statements, ... +''' myDatabase.CloseDatabase() +''' +''' 2) To access the database related to the current Base document +''' Dim myDoc As Object, myDatabase As Object, ui As Object +''' Set ui = CreateScriptService("UI") +''' Set myDoc = ui.OpenBaseDocument("myDb.odb") +''' Set myDatabase = myDoc.GetDatabase() ' user and password are supplied here, if needed +''' ' ... Run queries, SQL statements, ... +''' myDoc.CloseDocument() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_database.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DBREADONLYERROR = "DBREADONLYERROR" +Private Const SQLSYNTAXERROR = "SQLSYNTAXERROR" +Private Const SQLSYNTAX2ERROR = "SQLSYNTAX2ERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DATABASE +Private ServiceName As String +Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource +Private _Connection As Object ' com.sun.star.sdbc.XConnection +Private _URL As String ' Text on status bar +Private _Location As String ' File name +Private _ReadOnly As Boolean +Private _MetaData As Object ' com.sun.star.sdbc.XDatabaseMetaData +Private _User As String ' Connection parameters to enable a reconnection +Private _Password As String +Private _Datasets As Variant ' Array of open datasets + +REM ============================================================ MODULE CONSTANTS + +Const cstToken = "//" ' Form names accept special characters but not slashes + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DATABASE" + ServiceName = "SFDatabases.Database" + Set _DataSource = Nothing + Set _Connection = Nothing + _URL = "" + _Location = "" + _ReadOnly = True + Set _MetaData = Nothing + _User = "" + _Password = "" + _Datasets = Array() +End Sub ' SFDatabases.SF_Database Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDatabases.SF_Database Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDatabases.SF_Database Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Queries() As Variant +''' Return the list of available queries in the database + Queries = _PropertyGet("Queries") +End Property ' SFDatabases.SF_Database.Queries (get) + +REM ----------------------------------------------------------------------------- +Property Get Tables() As Variant +''' Return the list of available Tables in the database + Tables = _PropertyGet("Tables") +End Property ' SFDatabases.SF_Database.Tables (get) + +REM ----------------------------------------------------------------------------- +Property Get XConnection() As Variant +''' Return a com.sun.star.sdbc.XConnection UNO object + XConnection = _PropertyGet("XConnection") +End Property ' SFDatabases.SF_Database.XConnection (get) + +REM ----------------------------------------------------------------------------- +Property Get XMetaData() As Variant +''' Return a com.sun.star.sdbc.XDatabaseMetaData UNO object + XMetaData = _PropertyGet("XMetaData") +End Property ' SFDatabases.SF_Database.XMetaData (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Sub CloseDatabase() +''' Close the current database connection + +Const cstThisSub = "SFDatabases.Database.CloseDatabase" +Const cstSubArgs = "" + + On Local Error GoTo 0 ' Disable useless error checking + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + _CloseConnection() + Dispose() + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFDatabases.SF_Database.CloseDatabase + +REM ----------------------------------------------------------------------------- +Public Sub Commit() +''' Commit all updates done since the previous Commit or Rollback +''' The statement is ignored if the commits are done automatically after each SQL statement. +''' Args: +''' Returns: +''' Exceptions: +''' DBREADONLYERROR The method is not applicable on a read-only database +''' Example: +''' db.SetTransactionMode(4) ' Highest transaction level +''' db.RunSql("UPDATE ...") +''' db.Commit() +''' db.RunSql(DELETE ...") +''' If ...something happened... Then db.Rollback() Else db.Commit() +''' db.SetTransactionMode() ' Back to the automatic mode + +Const cstThisSub = "SFDatabases.Database.Commit" +Const cstSubArgs = "" + + On Local Error GoTo Finally + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If _ReadOnly Then GoTo Catch_ReadOnly + +Try: + With _Connection + If Not .AutoCommit Then + .commit() + ' To make updates potentially visible in the user interface ... + _FlushConnection() + End If + End With + +Finally: + On Local Error GoTo 0 + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch_ReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Sub ' SFDatabases.SF_Database.Commit + +REM ----------------------------------------------------------------------------- +Public Function CreateDataset(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSql As Variant _ + , Optional ByVal Filter As Variant _ + , Optional ByVal OrderBy As Variant _ + ) As Object +''' Create and return a Dataset class instance based on a table, a query +''' or an SQL SELECT statement. +''' Args: +''' SQLCommand: as a case-sensitive string, a table name, a query name +''' or a valid SQL SELECT statement. Identifiers may be surrounded +''' with square brackets +''' DirectSql: when True, the statement is processed by the targeted RDBMS +''' Filter: an additional condition that records must match, expressed +''' as a valid SQL WHERE clause without the WHERE keyword +''' OrderBy: the ordering of the dataset expressed as a valid SQL ORDER BY clause +''' without the ORDER BY keywords +''' Returns: +''' A SF_Dataset instance or Nothing when not successful +''' Exceptions +''' SQLSYNTAX2ERROR The given SQL statement is incorrect + +Dim oDataset As Object ' Return value +Dim bDirect As Boolean ' Alias of DirectSql +Dim sSql As String ' SQL statement +Dim sType As String ' TABLE, QUERY or SQL +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim ARR As Object : Set ARR = ScriptForge.SF_Array + +Const cstThisSub = "SFDatabases.Database.CreateDataset" +Const cstSubArgs = "SQLCommand, [DirectSQL=False], [Filter=""""], [OrderBy=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDataset = Nothing + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = "" + If IsMissing(OrderBy) Or IsEmpty(OrderBy) Then OrderBy = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(OrderBy, "OrderBy", V_STRING) Then GoTo Finally + End If + +Try: + ' Table, query of SQL ? Prepare dataset + If ARR.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + If Len(Filter) + Len(OrderBy) = 0 Then ' Filter seems not applicable on pure TABLE resultset + sType = "TABLE" + sSql = SQLCommand + Else + sType = "SQL" + sSql = "SELECT * FROM [" & SQLCommand & "]" + End If + bDirect = DirectSQL + ElseIf ARR.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + If Len(Filter) + Len(OrderBy) = 0 Then ' Filter seems not applicable on pure QUERY resultset + sType = "QUERY" + sSql = SQLCommand + Else + sType = "SQL" + sSql = oQuery.Command + End If + bDirect = Not oQuery.EscapeProcessing + ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sType = "SQL" + sSql = SQLCommand + bDirect = DirectSQL + Else + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING _ + , ARR.Flatten(ARR.Append(Tables, Queries))) Then GoTo Finally + End If + + Set oDataset = New SF_Dataset + With oDataset + Set .[Me] = oDataset + Set ._ParentDatabase = [Me] + ._DatasetType = sType + ._Command = SQLCommand + ._Sql = _ReplaceSquareBrackets(sSql) + ._DirectSql = bDirect + ._Filter = _ReplaceSquareBrackets(Filter) + ._OrderBy = _ReplaceSquareBrackets(OrderBy) + ._ReadOnly = _ReadOnly + ' If creation not successful, then cancel everything + If Not ._Initialize() Then Set oDataset = .Dispose() + End With + +Finally: + Set CreateDataset = oDataset + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.CreateDataset + +REM ----------------------------------------------------------------------------- +Public Function DAvg(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function AVG() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DAvg = _DFunction("Avg", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DAvg + +REM ----------------------------------------------------------------------------- +Public Function DCount(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function COUNT() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DCount = _DFunction("Count", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DCount + +REM ----------------------------------------------------------------------------- +Public Function DLookup(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + , Optional ByVal OrderClause As Variant _ + ) As Variant +''' Compute the aggregate function Lookup() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' To order the results, a pvOrderClause may be precised. The 1st record will be retained. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE +''' pvOrderClause: an optional order clause incl. "DESC" if relevant + + DLookup = _DFunction("Lookup", Expression, TableName, Criteria, OrderClause) + +End Function ' SFDatabases.SF_Database.DLookup + +REM ----------------------------------------------------------------------------- +Public Function DMax(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MAX() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMax = _DFunction("Max", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMax + +REM ----------------------------------------------------------------------------- +Public Function DMin(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MIN() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMin = _DFunction("Min", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMin + +REM ----------------------------------------------------------------------------- +Public Function DSum(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function Sum() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DSum = _DFunction("Sum", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DSum + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myDatabase.GetProperty("Queries") + +Const cstThisSub = "SFDatabases.Database.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetRows(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + , Optional ByVal Header As Variant _ + , Optional ByVal MaxRows As Variant _ + ) As Variant +''' Return the content of a table, a query or a SELECT SQL statement as an array +''' Args: +''' SQLCommand: a table name, a query name or a SELECT SQL statement +''' DirectSQL: when True, no syntax conversion is done by LO. Default = False +''' Ignored when SQLCommand is a table or a query name +''' Header: When True, a header row is inserted on the top of the array with the column names. Default = False +''' MaxRows: The maximum number of returned rows. If absent, all records are returned +''' Returns: +''' a 2D array(row, column), even if only 1 column and/or 1 record +''' an empty array if no records returned +''' Example: +''' Dim a As Variant +''' a = myDatabase.GetRows("SELECT [First Name], [Last Name] FROM [Employees] ORDER BY [Last Name]", Header := True) + +Dim vResult As Variant ' Return value +Dim oResult As Object ' com.sun.star.sdbc.XResultSet +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim sSql As String ' SQL statement +Dim bDirect ' Alias of DirectSQL +Dim lCols As Long ' Number of columns +Dim lRows As Long ' Number of rows +Dim oColumns As Object ' Collection of com.sun.star.sdb.ODataColumn +Dim bRead As Boolean ' When True, next record has been read successfully +Dim i As Long +Const cstThisSub = "SFDatabases.Database.GetRows" +Const cstSubArgs = "SQLCommand, [DirectSQL=False], [Header=False], [MaxRows=0]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Array() + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If IsMissing(Header) Or IsEmpty(Header) Then Header = False + If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Table, query of SQL ? Prepare resultset + If ScriptForge.SF_Array.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + sSql = "SELECT * FROM [" & SQLCommand & "]" + bDirect = True + ElseIf ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + sSql = oQuery.Command + bDirect = Not oQuery.EscapeProcessing + ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sSql = SQLCommand + bDirect = DirectSQL + Else + GoTo Finally + End If + + ' Execute command + Set oResult = _ExecuteSql(sSql, bDirect) + If IsNull(oResult) Then GoTo Finally + + With oResult + 'Initialize output array with header row + Set oColumns = .getColumns() + lCols = oColumns.Count - 1 + If Header Then + lRows = 0 + ReDim vResult(0 To lRows, 0 To lCols) + For i = 0 To lCols + vResult(lRows, i) = oColumns.getByIndex(i).Name + Next i + If MaxRows > 0 Then MaxRows = MaxRows + 1 + Else + lRows = -1 + End If + + ' Load data + bRead = .first() + Do While bRead And (MaxRows = 0 Or lRows < MaxRows - 1) + lRows = lRows + 1 + If lRows = 0 Then + ReDim vResult(0 To lRows, 0 To lCols) + Else + ReDim Preserve vResult(0 To lRows, 0 To lCols) + End If + For i = 0 To lCols + vResult(lRows, i) = _GetColumnValue(oResult, i + 1) + Next i + bRead = .next() + Loop + End With + +Finally: + GetRows = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetRows + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Database service as an array + + Methods = Array( _ + "CloseDatabase" _ + , "Commit" _ + , "CreateDataset" _ + , "DAvg" _ + , "DCount" _ + , "DLookup" _ + , "DMax" _ + , "DMin" _ + , "DSum" _ + , "GetRows" _ + , "OpenFormDocument" _ + , "OpenQuery" _ + , "OpenSql" _ + , "OpenTable" _ + , "Rollback" _ + , "RunSql" _ + , "SetTransactionMode" _ + ) + +End Function ' SFDatabases.SF_Database.Methods + +REM ----------------------------------------------------------------------------- +Public Function OpenFormDocument(Optional ByVal FormDocument As Variant) As Object +''' Open the FormDocument given by its hierarchical name in normal mode +''' If the form document is already open, the form document is made active +''' Args: +''' FormDocument: a valid form document name as a case-sensitive string +''' When hierarchical, the hierarchy must be rendered with forward slashes ("/") +''' Returns: +''' A FormDocument instance or Nothing +''' Exceptions: +''' Form name is invalid +''' Example: +''' Set oForm = oDb.OpenFormDocument("Folder1/myFormDocument") + +Dim oOpen As Object ' Return value +Dim oFormDocuments As Variant ' com.sun.star.comp.dba.ODocumentContainer +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim vOpenArgs As Variant ' Array of property values +Dim oNewForm As Object ' Output of loadComponent() +Const cstThisSub = "SFDatabases.Database.OpenFormDocument" +Const cstSubArgs = "FormDocument" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + ' Build list of available FormDocuments recursively with _CollectFormDocuments + Set oFormDocuments = _Connection.Parent.DataBaseDocument.FormDocuments + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + vFormNames = Split(_CollectFormDocuments(oFormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + End If + +Try: + vOpenArgs = Array(SF_Utils._MakePropertyValue("ActiveConnection", _Connection) _ + , SF_Utils._MakePropertyValue("OpenMode", "open") _ + ) + Set oNewForm = oFormDocuments.loadComponentFromURL(FormDocument, "", 0, vOpenArgs) + + Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDocuments.FormDocument", oNewForm) + + ' Prevent desynchronization when using .last(), .next() etc immediately after component loading. Bug #156836 + Wait 1 + +Finally: + Set OpenFormDocument = oOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Databases.SF_Database.OpenFormDocument + +REM ----------------------------------------------------------------------------- +Public Function OpenQuery(Optional ByVal QueryName As Variant) As Object +''' Open the query given by its name +''' The datasheet will live independently from any other (typically Base) component +''' Args: +''' QueryName: a valid query name as a case-sensitive string +''' Returns: +''' A Datasheet class instance if the query could be opened, otherwise Nothing +''' Exceptions: +''' Query name is invalid +''' Example: +''' oDb.OpenQuery("myQuery") + +Dim oOpen As Object ' Return value +Const cstThisSub = "SFDatabases.Database.OpenQuery" +Const cstSubArgs = "QueryName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(QueryName, "QueryName", V_STRING, Queries) Then GoTo Finally + End If + +Try: + Set oOpen = _OpenDatasheet(QueryName, com.sun.star.sdb.CommandType.QUERY _ + , _Connection.Queries.getByName(QueryName).EscapeProcessing) + +Finally: + Set OpenQuery = oOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function 'SFDatabases.SF_Database.OpenQuery + +REM ----------------------------------------------------------------------------- +Public Function OpenSql(Optional ByRef Sql As Variant _ + , Optional ByVal DirectSql As Variant _ + ) As Object +''' Open the datasheet based on a SQL SELECT statement. +''' The datasheet will live independently from any other (typically Base) component +''' Args: +''' Sql: a valid Sql statement as a case-sensitive string. +''' Identifiers may be surrounded by square brackets +''' DirectSql: when True, the statement is processed by the targeted RDBMS +''' Returns: +''' A Datasheet class instance if it could be opened, otherwise Nothing +''' Example: +''' oDb.OpenSql("SELECT * FROM [Customers] ORDER BY [CITY]") + +Dim oOpen As Object ' Return value +Const cstThisSub = "SFDatabases.Database.OpenSql" +Const cstSubArgs = "Sql, [DirectSql=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + If IsMissing(DirectSql) Or IsEmpty(DirectSql) Then DirectSql = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(Sql, "Sql", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSql, "DirectSql", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + Set oOpen = _OpenDatasheet(_ReplaceSquareBrackets(Sql), com.sun.star.sdb.CommandType.COMMAND, Not DirectSql) + +Finally: + Set OpenSql = oOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.OpenSql + +REM ----------------------------------------------------------------------------- +Public Function OpenTable(Optional ByVal TableName As Variant) As Object +''' Open the table given by its name +''' The datasheet will live independently from any other (typically Base) component +''' Args: +''' TableName: a valid table name as a case-sensitive string +''' Returns: +''' A Datasheet class instance if the table could be opened, otherwise Nothing +''' Exceptions: +''' Table name is invalid +''' Example: +''' oDb.OpenTable("myTable") + +Dim oOpen As Object ' Return value +Const cstThisSub = "SFDatabases.Database.OpenTable" +Const cstSubArgs = "TableName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(TableName, "TableName", V_STRING, Tables) Then GoTo Finally + End If + +Try: + Set oOpen = _OpenDatasheet(TableName, com.sun.star.sdb.CommandType.TABLE, True) + +Finally: + Set OpenTable = oOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.OpenTable + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Database class as an array + + Properties = Array( _ + "Queries" _ + , "Tables" _ + , "XConnection" _ + , "XMetaData" _ + ) + +End Function ' SFDatabases.SF_Database.Properties + +REM ----------------------------------------------------------------------------- +Public Sub Rollback() +''' Cancel all updates done since the previous Commit or Rollback +''' The statement is ignored if the commits are done automatically after each SQL statement. +''' Args: +''' Returns: +''' Exceptions: +''' DBREADONLYERROR The method is not applicable on a read-only database +''' Example: +''' db.SetTransactionMode(4) ' Highest transaction level +''' db.RunSql("UPDATE ...") +''' db.Commit() +''' db.RunSql(DELETE ...") +''' If ...something happened... Then db.Rollback() Else db.Commit() +''' db.SetTransactionMode() ' Back to the automatic mode + +Const cstThisSub = "SFDatabases.Database.Rollback" +Const cstSubArgs = "" + + On Local Error GoTo Finally + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If _ReadOnly Then GoTo Catch_ReadOnly + +Try: + With _Connection + If Not .AutoCommit Then .rollback() + End With + +Finally: + On Local Error GoTo 0 + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch_ReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Sub ' SFDatabases.SF_Database.Rollback + +REM ----------------------------------------------------------------------------- +Public Function RunSql(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + ) As Boolean +''' Execute an action query (table creation, record insertion, ...) or SQL statement on the current database +''' Args: +''' SQLCommand: a query name or an SQL statement +''' DirectSQL: when True, no syntax conversion is done by LO. Default = False +''' Ignored when SQLCommand is a query name +''' Exceptions: +''' DBREADONLYERROR The method is not applicable on a read-only database +''' Example: +''' myDatabase.RunSql("INSERT INTO [EMPLOYEES] VALUES(25, 'SMITH', 'John')", DirectSQL := True) + +Dim bResult As Boolean ' Return value +Dim oStatement As Object ' com.sun.star.sdbc.XStatement +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim sSql As String ' SQL statement +Dim bDirect ' Alias of DirectSQL +Const cstQuery = 2, cstSql = 3 +Const cstThisSub = "SFDatabases.Database.RunSql" +Const cstSubArgs = "SQLCommand, [DirectSQL=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bResult = False + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + If _ReadOnly Then GoTo Catch_ReadOnly + +Try: + ' Query of SQL ? + If ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + sSql = oQuery.Command + bDirect = Not oQuery.EscapeProcessing + ElseIf Not ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sSql = SQLCommand + bDirect = DirectSQL + Else + GoTo Finally + End If + + ' Execute command + bResult = _ExecuteSql(sSql, bDirect) + +Finally: + RunSql = bResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +Catch_ReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Database.RunSql + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDatabases.Database.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SetTransactionMode(Optional ByVal TransactionMode As Variant) As Boolean +''' Configure the handling of transactions. +''' Usually all transactions are in auto-commit mode, that means, a commit takes place +''' after each single SQL command. Therefore to control a transaction manually, implies to switch auto-commit off. +''' The first SQL command starts a transaction that is active until the corresponding +''' methods have been committed or rolled back. +''' +''' The transaction mode remains valid until the next call of the method with a different value, +''' or until the closure of the actual Database instance, +''' or until a call to SetTransactionMode() without argument, which cancels the manual transaction mode. +''' +''' The method may close and replace the actual connection. This means that all open datasets +''' are first closed. Open datasheets might see their content changed or vanish. +''' The easiest is to set the transaction mode immediately after the creation of the Database instance. +''' +''' Args: +''' TransactionMode: one of the com.sun.star.sdbc.TransactionIsolation constants: +''' (0) NONE Indicates that transactions are not supported. Default: cancel the transaction mode. +''' (1) READ_UNCOMMITTED Dirty reads, non-repeatable reads and phantom reads can occur. +''' This level allows a row changed by one transaction to be read by another transaction +''' before any changes in that row have been committed (a "dirty read"). +''' If any of the changes are rolled back, the second transaction will have retrieved an invalid row. +''' (2) READ_COMMITTED Dirty reads are prevented; non-repeatable reads and phantom reads can occur. +''' This level only prohibits a transaction from reading a row with uncommitted changes in it. +''' (4) REPEATABLE_READ Dirty reads and non-repeatable reads are prevented; phantom reads can occur. +''' This level prohibits a transaction from reading a row with uncommitted changes in it, +''' and it also prohibits the situation where one transaction reads a row, +''' a second transaction alters the row, and the first transaction rereads the row, +''' getting different values the second time (a "non-repeatable read"). +''' (8) SERIALIZABLE Dirty reads, non-repeatable reads and phantom reads are prevented. +''' This level includes the prohibitions in REPEATABLE_READ and further prohibits +''' the situation where one transaction reads all rows that satisfy a WHERE condition, +''' a second transaction inserts a row that satisfies that WHERE condition, +''' and the first transaction rereads for the same condition, retrieving +''' the additional "phantom" row in the second read. +''' Returns: +''' True when successful. +''' Exceptions: +''' DBREADONLYERROR The method is not applicable on a read-only database +''' Example: +''' oDb.SetTransactionMode(com.sun.star.sdbc.TransactionIsolation.SERIALIZABLE) ' 8 + +Dim bSet As Boolean ' Return value +Dim bCommit As Boolean ' To compare with AutoCommit +Const cstThisSub = "SFDatabases.Database.SetTransactionMode" +Const cstSubArgs = "TransactionMode=0|1|2|4|8" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + +Check: + If IsMissing(TransactionMode) Or IsEmpty(TransactionMode) Then TransactionMode = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(TransactionMode, "TransactionMode", ScriptForge.V_NUMERIC, Array(0, 1, 2, 4, 8)) Then GoTo Finally + End If + If _ReadOnly Then GoTo Catch_ReadOnly + +Try: + With _Connection + bCommit = ( TransactionMode > com.sun.star.sdbc.TransactionIsolation.NONE ) + ' Replace the existing connection + If Not IsNull(_Connection) Then + If .AutoCommit And bCommit Then + _CloseConnection() + Set _Connection = _DataSource.getIsolatedConnection(_User, _Password) + ElseIf Not .AutoCommit And Not bCommit Then + _CloseConnection() + Set _Connection = _DataSource.getConnection(_User, _Password) + End If + End If + + ' Set the transaction mode + If bCommit Then + .SetTransactionIsolation(CLng(TransactionMode)) + .setAutoCommit(Not bCommit) + End If + End With + + bSet = True + +Finally: + SetTransactionMode = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +Catch_ReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Database.SetTransactionMode + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _AddToDatasets(ByRef poDataset As Object) As Long +''' Insert a newly created Dataset instance in the open datasets array +''' and return the index of the used entry. +''' Empty space is reused. +''' Args: +''' poDataset: the dataset instance to insert + +Dim lIndex As Long ' Return value +Dim lSize As Long ' UBound of the _datasets array +Dim i As Long + +Check: + lIndex = -1 + If IsNull(poDataset) Then Exit Function + On Local Error GoTo Finally + lSize = UBound(_Datasets) + +Try: + ' Can an empty entry be reused ? + For i = 0 To lSize + If IsNull(_Datasets(i)) Then + lIndex = i + Exit For + End If + Next i + + ' Resize _Datasets if no empty space + If lIndex < 0 Then + lSize = lSize + 1 + If lSize > 0 Then + ReDim Preserve _Datasets(0 To lSize) + Else + ReDim _Datasets (0 To 0) + End If + lIndex = lSize + End If + + ' Insert new object + Set _Datasets(lIndex) = poDataset + +Finally: + _AddToDatasets = lIndex + Exit Function +End Function ' SFDatabases.SF_Database._AddToDatasets + +REM ----------------------------------------------------------------------------- +Private Sub _CloseConnection() +''' Close the actual connection +''' To enable transaction modes, it is necessary to reinitialize the connection to the datasource. +''' The reinit includes +''' - the closure of all open datasets +''' - flushing the buffered and committed updates +''' - the effective closure +''' Otherwise the experience showed undesired side-effects. + +Dim oParent As Object ' Parent of actual connection +Dim oDataset As Object ' Single dataset in the _Datasets array +Dim oSession As Object : Set oSession = ScriptForge.SF_Session +Dim i As Long + + On Local Error GoTo Finally ' Never abort + +Check: + If IsNull(_Connection) Then Exit Sub + +Try: + ' Close datasets + For i = 0 To UBound(_Datasets) + Set oDataset = _Datasets(i) + If Not IsNull(oDataset) Then oDataset.CloseDataset() + Set _Datasets(i) = Nothing + Next i + _Datasets = Array() + + ' Flush buffers + _FlushConnection() + + ' Close the connection + _Connection.close() + _Connection.dispose() + +Finally: + On Local Error GoTo 0 + Exit Sub +End Sub ' SFDatabases.SF_Database._CloseConnection + +REM ----------------------------------------------------------------------------- +Private Function _CollectFormDocuments(ByRef poContainer As Object) As String +''' Returns a token-separated string of all hierarchical formdocument names +''' depending on the formdocuments container in argument +''' The function traverses recursively the whole tree below the container +''' The initial call starts from the container _Component.getFormDocuments +''' The list contains closed and open forms + +Dim sCollectNames As String ' Return value +Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form) +Dim i As Long +Const cstFormType = "application/vnd.oasis.opendocument.text" + ' Identifies forms. Folders have a zero-length content type + + On Local Error GoTo Finally + +Try: + sCollectNames = "" + With poContainer + For i = 0 To .Count - 1 + Set oSubItem = .getByIndex(i) + If oSubItem.ContentType = cstFormType Then ' Add the form to the list + sCollectNames = sCollectNames & cstToken & oSubItem.HierarchicalName + Else + sCollectNames = sCollectNames & cstToken & _CollectFormDocuments(oSubItem) + End If + Next i + End With + +Finally: + If Len(sCollectNames) > 0 Then + _CollectFormDocuments = Mid(sCollectNames, Len(cstToken) + 1) ' Skip the initial token + Else + _CollectFormDocuments = "" + End If + Exit Function +End Function ' SFDatabases.SF_Database._CollectFormDocuments + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , Optional ByVal pvExpression As Variant _ + , Optional ByVal pvTableName As Variant _ + , Optional ByVal pvCriteria As Variant _ + , Optional ByVal pvOrderClause As Variant _ + ) As Variant +''' Build and execute a SQL statement computing the aggregate function psFunction +''' on a field or expression pvExpression belonging to a table pvTableName +''' filtered by a WHERE-clause pvCriteria. +''' To order the results, a pvOrderClause may be precised. +''' Only the 1st record will be retained anyway. +''' Args: +''' psFunction an optional aggregate function: SUM, COUNT, AVG, LOOKUP +''' pvExpression: an SQL expression +''' pvTableName: the name of a table, NOT surrounded with quoting char +''' pvCriteria: an optional WHERE clause without the word WHERE +''' pvOrderClause: an optional order clause incl. "DESC" if relevant +''' (meaningful only for LOOKUP) + +Dim vResult As Variant ' Return value +Dim oResult As Object ' com.sun.star.sdbc.XResultSet +Dim sSql As String ' SQL statement. +Dim sExpr As String ' For inclusion of aggregate function +Dim sTarget as String ' Alias of pvExpression +Dim sWhere As String ' Alias of pvCriteria +Dim sOrderBy As String ' Alias of pvOrderClause +Dim sLimit As String ' TOP 1 clause +Dim sProductName As String ' RDBMS as a string +Const cstAliasField = "[" & "TMP_ALIAS_ANY_FIELD" & "]" ' Alias field in SQL expression +Dim cstThisSub As String : cstThisSub = "SFDatabases.SF_Database.D" & psFunction +Const cstSubArgs = "Expression, TableName, [Criteria=""""], [OrderClause=""""]" +Const cstLookup = "Lookup" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Null + +Check: + If IsMissing(pvCriteria) Or IsEmpty(pvCriteria) Then pvCriteria = "" + If IsMissing(pvOrderClause) Or IsEmpty(pvOrderClause) Then pvOrderClause = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(pvExpression, "Expression", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvTableName, "TableName", V_STRING, Tables) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvCriteria, "Criteria", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvOrderClause, "OrderClause", V_STRING) Then GoTo Finally + End If + +Try: + If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = "" + If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = "" + sLimit = "" + + pvTableName = "[" & pvTableName & "]" + + sProductName = UCase(_MetaData.getDatabaseProductName()) + + Select Case sProductName + Case "MYSQL", "SQLITE" + If psFunction = cstLookup Then + sTarget = pvExpression + sLimit = " LIMIT 1" + Else + sTarget = UCase(psFunction) & "(" & pvExpression & ")" + End If + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & psTableName & sWhere & sOrderBy & sLimit + Case "FIREBIRD (ENGINE12)" + If psFunction = cstLookup Then sTarget = "FIRST 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")" + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy + Case Else ' Standard syntax - Includes HSQLDB + If psFunction = cstLookup Then sTarget = "TOP 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")" + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy + End Select + + ' Execute the SQL statement and retain the first column of the first record + Set oResult = _ExecuteSql(sSql, True) + If Not IsNull(oResult) And Not IsEmpty(oResult) Then + If oResult.first() Then vResult = _GetColumnValue(oResult, 1) Else GoTo Finally + End If + Set oResult = Nothing + +Finally: + _DFunction = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._DFunction + +REM ----------------------------------------------------------------------------- +Private Function _ExecuteSql(ByVal psSql As String _ + , ByVal pbDirect As Boolean _ + ) As Variant +''' Return a read-only Resultset based on a SELECT SQL statement or execute the given action SQL (INSERT, CREATE TABLE, ...) +''' The method raises a fatal error when the SQL statement cannot be interpreted +''' Args: +''' psSql : the SQL statement. Square brackets are replaced by the correct field surrounding character +''' pbDirect: when True, no syntax conversion is done by LO. Default = False +''' Exceptions +''' SQLSYNTAXERROR The given SQL statement is incorrect + +Dim vResult As Variant ' Return value - com.sun.star.sdbc.XResultSet or Boolean +Dim oStatement As Object ' com.sun.star.sdbc.XStatement +Dim sSql As String ' Alias of psSql +Dim bSelect As Boolean ' True when SELECT statement +Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements + + Set vResult = Nothing + bErrorHandler = ScriptForge.SF_Utils._ErrorHandling() + If bErrorHandler Then On Local Error GoTo Catch + +Try: + sSql = _ReplaceSquareBrackets(psSql) + bSelect = ScriptForge.SF_String.StartsWith(sSql, "SELECT", CaseSensitive := False) + + Set oStatement = _Connection.createStatement() + With oStatement + If bSelect Then + .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + End If + .EscapeProcessing = Not pbDirect + + ' Setup the result set + If bErrorHandler Then On Local Error GoTo Catch_Sql + If bSelect Then Set vResult = .executeQuery(sSql) Else vResult = .execute(sSql) + End With + +Finally: + _ExecuteSql = vResult + Set oStatement = Nothing + Exit Function +Catch_Sql: + On Local Error GoTo 0 + ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAXERROR, sSql) + GoTo Finally +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._ExecuteSql + +REM ----------------------------------------------------------------------------- +Private Sub _FlushConnection() +''' Empties the buffers of the actual connection +''' Sub called after each commit and at connection closure.. + +Dim oParent As Object ' Parent of actual connection +Dim oSession As Object : Set oSession = ScriptForge.SF_Session + + On Local Error GoTo Finally ' Never abort + +Check: + If IsNull(_Connection) Then Exit Sub + +Try: + ' Flush buffers + With oSession + If .HasUnoMethod(_Connection, "getParent") Then + Set oParent = _Connection.getParent() + If .HasUnoMethod(oParent, "flush") Then oParent.flush() + ElseIf .HasUnoMethod(_Connection, "flush") Then + _Connection.flush() + End If + End With + +Finally: + Exit Sub +End Sub ' SFDatabases.SF_Database._FlushConnection + +REM ----------------------------------------------------------------------------- +Private Function _GetColumnValue(ByRef poResultSet As Object _ + , ByVal plColIndex As Long _ + ) As Variant +''' Get the data stored in the current record of a result set in a given column +''' The type of the column is found in the resultset's metadata +''' Args: +''' poResultSet: com.sun.star.sdbc.XResultSet or com.sun.star.awt.XTabControllerModel +''' plColIndex: the index of the column to extract the value from. Starts at 1 +''' Returns: +''' The Variant value found in the column +''' Dates and times are returned as Basic dates +''' Null values are returned as Null +''' Binary fields are returned as a Long giving their length +''' Errors or strange data types are returned as Null as well + +Dim vValue As Variant ' Return value +Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType +Dim vDateTime As Variant ' com.sun.star.util.DateTime +Dim oStream As Object ' Long character or binary streams +Dim bNullable As Boolean ' The field is defined as accepting Null values +Dim lSize As Long ' Binary field length + +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + vValue = Empty ' Default value if error + + With com.sun.star.sdbc.DataType + lType = poResultSet.MetaData.getColumnType(plColIndex) + bNullable = ( poResultSet.MetaData.IsNullable(plColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + + Select Case lType + Case .ARRAY : vValue = poResultSet.getArray(plColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oStream = poResultSet.getBinaryStream(plColIndex) + If IsNull(oStream) Then + lSize = 0 + Else + If bNullable Then + If Not poResultSet.wasNull() Then lSize = CLng(oStream.getLength()) Else lSize = 0 + Else + lSize = CLng(oStream.getLength()) + End If + oStream.closeInput() + End If + vValue = lSize ' Return length of field, not content + Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(plColIndex) + Case .DATE + vDateTime = poResultSet.getDate(plColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) + Case .DISTINCT, .OBJECT, .OTHER, .STRUCT + vValue = Null + Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(plColIndex) + Case .FLOAT : vValue = poResultSet.getFloat(plColIndex) + Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(plColIndex) + Case .BIGINT : vValue = CLng(poResultSet.getLong(plColIndex)) + Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(plColIndex) + Case .SQLNULL : vValue = poResultSet.getNull(plColIndex) + Case .REF : vValue = poResultSet.getRef(plColIndex) + Case .TINYINT : vValue = poResultSet.getShort(plColIndex) + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + vValue = poResultSet.getString(plColIndex) + Case .TIME + vDateTime = poResultSet.getTime(plColIndex) + If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case .TIMESTAMP + vDateTime = poResultSet.getTimeStamp(plColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _ + + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case Else + vValue = poResultSet.getString(plColIndex) 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + ' .wasNull() must be preceded by getXXX(). Done. Test for Null here. + If bNullable Then + If poResultSet.wasNull() Then vValue = Null + End If + End With + + _GetColumnValue = vValue + +End Function ' SFDatabases.SF_Database._GetColumnValue + +REM ----------------------------------------------------------------------------- +Public Function _OpenDatasheet(Optional ByVal psCommand As Variant _ + , piDatasheetType As Integer _ + , pbEscapeProcessing As Boolean _ + ) As Object +''' Open the datasheet given by its name and its type +''' The datasheet will live independently from any other component +''' Args: +''' psCommand: a valid table or query name or an SQL statement as a case-sensitive string +''' piDatasheetType: one of the com.sun.star.sdb.CommandType constants +''' pbEscapeProcessing: == Not DirectSql +''' Returns: +''' A Datasheet class instance if the datasheet could be opened, otherwise Nothing + +Dim oOpen As Object ' Return value +Dim oNewDatasheet As Object ' com.sun.star.lang.XComponent +Dim oURL As Object ' com.sun.star.util.URL +Dim oDispatch As Object ' com.sun.star.frame.XDispatch +Dim vArgs As Variant ' Array of property values + + On Local Error GoTo Catch + Set oOpen = Nothing + +Try: + ' Setup the dispatcher + Set oURL = New com.sun.star.util.URL + oURL.Complete = ".component:DB/DataSourceBrowser" + Set oDispatch = StarDesktop.queryDispatch(oURL, "_blank", com.sun.star.frame.FrameSearchFlag.CREATE) + + ' Setup the arguments of the component to create + With ScriptForge.SF_Utils + vArgs = Array( _ + ._MakePropertyValue("ActiveConnection", _Connection) _ + , ._MakePropertyValue("CommandType", piDatasheetType) _ + , ._MakePropertyValue("Command", psCommand) _ + , ._MakePropertyValue("ShowMenu", True) _ + , ._MakePropertyValue("ShowTreeView", False) _ + , ._MakePropertyValue("ShowTreeViewButton", False) _ + , ._MakePropertyValue("Filter", "") _ + , ._MakePropertyValue("ApplyFilter", False) _ + , ._MakePropertyValue("EscapeProcessing", pbEscapeProcessing) _ + ) + End With + + ' Open the targeted datasheet + Set oNewDatasheet = oDispatch.dispatchWithReturnValue(oURL, vArgs) + If Not IsNull(oNewDatasheet) Then Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Datasheet", oNewDatasheet, [Me]) + +Finally: + Set _OpenDatasheet = oOpen + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base._OpenDatasheet + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDatabases.Database.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case psProperty + Case "Queries" + If Not IsNull(_Connection) Then _PropertyGet = _Connection.Queries.getElementNames() Else _PropertyGet = Array() + Case "Tables" + If Not IsNull(_Connection) Then _PropertyGet = _Connection.Tables.getElementNames() Else _PropertyGet = Array() + Case "XConnection" + Set _PropertyGet = _Connection + Case "XMetaData" + Set _PropertyGet = _MetaData + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _ReplaceSquareBrackets(ByVal psSql As String) As String +''' Returns the input SQL command after replacement of square brackets by the table/field names quoting character + +Dim sSql As String ' Return value +Dim sQuote As String ' RDBMS specific table/field surrounding character +Dim sConstQuote As String ' Delimiter for string constants in SQL - usually the single quote +Const cstDouble = """" : Const cstSingle = "'" + +Try: + sQuote = _MetaData.IdentifierQuoteString + sConstQuote = Iif(sQuote = cstSingle, cstDouble, cstSingle) + + ' Replace the square brackets + sSql = Join(ScriptForge.SF_String.SplitNotQuoted(psSql, "[", , sConstQuote), sQuote) + sSql = Join(ScriptForge.SF_String.SplitNotQuoted(sSql, "]", , sConstQuote), sQuote) + +Finally: + _ReplaceSquareBrackets = sSql + Exit Function +End Function ' SFDatabases.SF_Database._ReplaceSquareBrackets + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Database instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DATABASE]: Location (Statusbar)" + + _Repr = "[DATABASE]: " & _Location & " (" & _URL & ")" + +End Function ' SFDatabases.SF_Database._Repr + +REM ============================================ END OF SFDATABASES.SF_DATABASE +</script:module>
\ No newline at end of file |