diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-15 05:54:39 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-15 05:54:39 +0000 |
| commit | 267c6f2ac71f92999e969232431ba04678e7437e (patch) | |
| tree | 358c9467650e1d0a1d7227a21dac2e3d08b622b2 /wizards/source/sfdatabases | |
| parent | Initial commit. (diff) | |
| download | libreoffice-267c6f2ac71f92999e969232431ba04678e7437e.tar.xz libreoffice-267c6f2ac71f92999e969232431ba04678e7437e.zip | |
Adding upstream version 4:24.2.0.upstream/4%24.2.0
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'wizards/source/sfdatabases')
| -rw-r--r-- | wizards/source/sfdatabases/SF_Database.xba | 1475 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/SF_Dataset.xba | 1672 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/SF_Datasheet.xba | 952 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/SF_Register.xba | 280 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/__License.xba | 26 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/dialog.xlb | 3 | ||||
| -rw-r--r-- | wizards/source/sfdatabases/script.xlb | 9 |
7 files changed, 4417 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 diff --git a/wizards/source/sfdatabases/SF_Dataset.xba b/wizards/source/sfdatabases/SF_Dataset.xba new file mode 100644 index 0000000000..02b3d35aff --- /dev/null +++ b/wizards/source/sfdatabases/SF_Dataset.xba @@ -0,0 +1,1672 @@ +<?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_Dataset" 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_Dataset +''' ========== +''' A dataset represents a set of tabular data produced by a database. +''' In the user interface of LibreOffice a dataset corresponds with the data +''' displayed in a form or a data sheet (table, query). +''' To use datasets, the database instance must exist but the Base document may not be open. +''' +''' In the context of ScriptForge, a dataset may be created automatically by script code : +''' - at any moment => in this case the Base document may or may not be open. +''' - any SELECT SQL statement may define the dataset. +''' +''' The proposed API supports next main purposes: +''' - browse for- and backward through the dataset to get its content +''' - update any record with new values +''' - create new records or delete some. +''' So-called "CRUD" operations (create, read, update, delete). +''' +''' Service invocation: +''' A dataset is characterized by +''' - the parent database +''' - a table/query name or an SQL SELECT statement +''' - the DirectSQL option to bypass the processing of SQL by LibreOffice +''' - an optional filter +''' - an optional sorting order +''' 1) From a database class instance +''' Dim db As Object, FileName As String, Dataset As Object, Dataset2 As Object +''' Set db = CreateScriptService("SFDatabases.Database", FileName, , ReadOnly := False) +''' Set Dataset = db.CreateDataset("myTable", DirectSql := False, Filter := "[City]='Brussels'") +''' 2) From an existing dataset +''' Set Dataset2 = Dataset.CreateDataset(Filter := "[City]='Paris'") +''' +''' Dataset browsing with the MoveNext(), MovePrevious(), ... methods +''' After creation of the dataset, the current record is positioned BEFORE the first record. +''' Every MoveXXX() method returns False when no record could be retrieved, otherwise True. +''' When False, the current record is reset either in BOF or EOF positions. +''' Typically: +''' Set dataset = db.CreateDataset("myTable") +''' With Dataset +''' Do While .MoveNext() +''' ... +''' Loop +''' .CloseDataset() +''' End With +''' +''' Updates performance: +''' This module provides methods to update data stored in database tables. +''' Note that the proposed Update() and Insert() methods will always be +''' SLOWER or MUCH SLOWER than equivalent SQL statements. +''' Always privilege SQL when considering massive updates. +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/SF_Dataset.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +' Error in the dataset's initial SQL statement +Private Const SQLSYNTAX2ERROR = "SQLSYNTAX2ERROR" +' The current record could not be determined +Private Const NOCURRENTRECORDERROR = "NOCURRENTRECORDERROR" +' Database is read-only. Method rejected +Private Const DBREADONLYERROR = "DBREADONLYERROR" +' Database fields update error +' Value to store does not fit the type of the field +' Field is not nullable and value = Null +' Field is not writable or autovalue +' Input file does not exist or is empty +' Field type is not supported +Private Const RECORDUPDATEERROR = "RECORDUPDATEERROR" +' The destination file exists and cannot be overwritten +Private Const FIELDEXPORTERROR = "FIELDEXPORTERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private ObjectType As String ' Must be DATASET +Private ServiceName As String + +Private _ParentDatabase As Object ' The parent SF_Database instance (must not be void) +Private _DatasetType As String ' TABLE, QUERY or SQL +Private _Command As String ' Table name, query name or SQL statement +Private _Sql As String ' Equivalent SQL command +Private _DirectSql As Boolean ' When True, SQL processed by RDBMS +Private _Filter As String ' WHERE clause without WHERE +Private _OrderBy As String ' ORDER BY clause without ORDER BY +Private _ReadOnly As Boolean ' When True, updates are forbidden + +Private _RowSet As Object ' com.sun.star.sdb.RowSet + +Private _Fields As Variant ' Array of field names +Private _UpdatableFields As Variant ' Array of updatable field names +Private _DefaultValues As Variant ' Array of field default values // _Fields +Private _AutoValue As Long ' Index of AutoValue field. None = -1 + +Private _DatasetIndex As Long ' Index of the dataset in the _Datasets array of the parent database + +REM ============================================================ MODULE CONSTANTS + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + ObjectType = "DATASET" + ServiceName = "SFDatabases.Dataset" + Set _ParentDatabase = Nothing + _DatasetType = "" + _Command = "" + _DirectSql = False + _Filter = "" + _OrderBy = "" + _ReadOnly = False + Set _RowSet = Nothing + _Fields = Array() + _UpdatableFields = Array() + _DefaultValues = Array() + _AutoValue = -1 + _DatasetIndex = -1 +End Sub ' SFDatabases.SF_Dataset Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDatabases.SF_Dataset Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDatabases.SF_Dataset Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get BOF() As Variant +''' The BOF property returns True if the current record position is before the first record +''' in the Dataset, otherwise it returns False. + Bof = _PropertyGet("BOF") +End Property ' SFDatabases.SF_Dataset.BOF (get) + +REM ----------------------------------------------------------------------------- +Property Let BOF(Optional ByVal pvBOF As Variant) +''' Set the updatable property BOF. +''' Setting BOF to True positions the current record before the first record. +''' Setting it to False is ignored. True is the only relevant value. + _PropertySet("BOF", pvBOF) +End Property ' SFDatabases.SF_Dataset.BOF (let) + +REM ----------------------------------------------------------------------------- +Property Get DefaultValues() As Variant +''' Returns a dictionary (field name => default value). +''' The database field type is converted to the corresponding Basic/Python variable types. +''' When undefined: returns either Null (field is nullable) or Empty +''' The output dictionary should be disposed by the user script + DefaultValues = _PropertyGet("DefaultValues") +End Property ' SFDatabases.SF_Dataset.DefaultValues (get) + +REM ----------------------------------------------------------------------------- +Property Get EOF() As Variant +''' The EOF property returns True if the current record position is after the last record +''' in the Dataset, otherwise it returns False. + EOF = _PropertyGet("EOF") +End Property ' SFDatabases.SF_Dataset.EOF (get) + +REM ----------------------------------------------------------------------------- +Property Let EOF(Optional ByVal pvEOF As Variant) +''' Set the updatable property EOF. +''' Setting EOF to True positions the current record after the last record. +''' Setting it to False is ignored. True is the only relevant value. + _PropertySet("EOF", pvEOF) +End Property ' SFDatabases.SF_Dataset.EOF (let) + +REM ----------------------------------------------------------------------------- +Property Get Fields() As Variant +''' Returns the list of the field names contained in the dataset + Fields = _PropertyGet("Fields") +End Property ' SFDatabases.SF_Dataset.Fields (get) + +REM ----------------------------------------------------------------------------- +Property Get Filter() As Variant +''' The Filter is a SQL WHERE clause without the WHERE keyword + Filter = _PropertyGet("Filter") +End Property ' SFDatabases.SF_Dataset.Filter (get) + +REM ----------------------------------------------------------------------------- +Property Get OrderBy() As Variant +''' The OrderBy is an SQL ORDER BY clause without the ORDER BY keyword + OrderBy = _PropertyGet("OrderBy") +End Property ' SFDatabases.SF_Dataset.OrderBy (get) + +REM ----------------------------------------------------------------------------- +Property Get ParentDatabase() As Object +''' Returns the database instance to which the dataset belongs + Set ParentDatabase = _PropertyGet("ParentDatabase") +End Property ' SFDatabases.SF_Dataset.ParentDatabase + +REM ----------------------------------------------------------------------------- +Property Get RowCount() As Long +''' Returns the number of records present in the dataset +''' When that number exceeds a certain limit, its determination requires +''' that the whole dataset has been read first, up to its last row. +''' For huge datasets, this can represent a significant performance cost. + RowCount = _PropertyGet("RowCount") +End Property ' SFDatabases.SF_Dataset.RowCount + +REM ----------------------------------------------------------------------------- +Property Get RowNumber() As Long +''' Returns the sequence number >= 1 of the current record. Returns 0 if unknown. + RowNumber = _PropertyGet("RowNumber") +End Property ' SFDatabases.SF_Dataset.RowNumber + +REM ----------------------------------------------------------------------------- +Property Get Source() As String +''' Returns the source of the data: table name, query name or sql statement + Source = _PropertyGet("Source") +End Property ' SFDatabases.SF_Dataset.Source + +REM ----------------------------------------------------------------------------- +Property Get SourceType() As String +''' Returns the type of source of the data: TABLE, QUERY or SQL + SourceType = _PropertyGet("SourceType") +End Property ' SFDatabases.SF_Dataset.SourceType + +REM ----------------------------------------------------------------------------- +Property Get UpdatableFields() As Variant +''' Returns the list of the names of the updatable fields contained in the dataset + UpdatableFields = _PropertyGet("UpdatableFields") +End Property ' SFDatabases.SF_Dataset.UpdatableFields (get) + +REM ----------------------------------------------------------------------------- +Property Get Values() As Variant +''' Returns a dictionary (field name => field value) applied on the current record +''' Binary fields ? => their length is returned +''' The output dictionary should be disposed by the user script +''' Returns Nothing when there is no current record + Values = _PropertyGet("Values") +End Property ' SFDatabases.SF_Dataset.Values (get) + +REM ----------------------------------------------------------------------------- +Property Get XRowSet() As Object +''' Returns the com.sun.star.sdb.RowSet UNO object representing the dataset + XRowSet = _PropertyGet("XRowSet") +End Property ' SFDocuments.SF_Document.XRowSet + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function CloseDataset() As Boolean +''' Close the actual dataset +''' Args: +''' Returns: +''' True when successful +''' Examples: +''' dataset.CloseDataset() + +Dim bClose As Boolean ' Return value +Const cstThisSub = "SFDatabases.Sataset.CloseDataset" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If Not IsNull(_RowSet) Then + With _RowSet + .close() + .dispose() + End With + If _DatasetIndex >= 0 Then Set _ParentDatabase._Datasets(_DatasetIndex) = Nothing + Dispose() + bClose = True + End If + +Finally: + CloseDataset = bClose + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.CloseDataset + +REM ----------------------------------------------------------------------------- +Public Function CreateDataset(Optional ByVal Filter As Variant _ + , Optional ByVal OrderBy As Variant _ + ) As Object +''' Create and return a Dataset class instance based on the actual Dataset +''' Filter and OrderBy properties may be redefined. +''' Args: +''' Filter: an additional condition that records must match, expressed +''' as a valid SQL WHERE clause without the WHERE keyword +''' Default: the filter applied on the actual dataset. +''' OrderBy: the ordering of the dataset expressed as a valid SQL ORDER BY clause +''' without the ORDER BY keywords. +''' Default: the same sorting order as the actual dataset. +''' Returns: +''' A SF_Dataset instance or Nothing when not successful +''' Exceptions +''' SQLSYNTAX2ERROR The given SQL statement is incorrect +''' Examples: +''' Dim ds1 As Object, ds2 As Object, ds3 As Object, ds4 As Object +''' Set ds1 = dataset.CreateDataset() ' dataset and ds1 contain the same set of data +''' Set ds2 = dataset.CreateDataset(Filter := "") ' Suppress the current filter +''' Set ds3 = dataset.CreateDataset(Filter := "[Name] LIKE 'A%'") +''' ' Define a new filter +''' Set ds4 = dataset.CreateDataset(Filter := "(" & dataset.Filter & ") AND [Name] LIKE 'A%'") +''' ' Combine actual filter with an additional condition + +Dim oDataset As Object ' Return value + +Const cstThisSub = "SFDatabases.Dataset.CreateDataset" +Const cstSubArgs = "[Filter=""...filter...""], [OrderBy=""...orderby...""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDataset = Nothing + +Check: + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = _Filter + If IsMissing(OrderBy) Or IsEmpty(OrderBy) Then OrderBy = _OrderBy + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + 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: + Set oDataset = New SF_Dataset + With oDataset + Set .[Me] = oDataset + Set ._ParentDatabase = _ParentDatabase + ._DatasetType = _DatasetType + ._Command = _Command + ._Sql = _Sql + ._DirectSql = _DirectSql + ._Filter = _ParentDatabase._ReplaceSquareBrackets(Filter) + ._OrderBy = _ParentDatabase._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_Dataset.CreateDataset + +REM ----------------------------------------------------------------------------- +Public Function Delete() As Boolean +''' Deletes the current record, from the dataset and from the database. +''' The cursor is set on the record following immediately the deleted record, +''' or after the last record if the deleted one was the last one. +''' Args: +''' Returns: +''' True when successful +''' Exceptions: +''' DBREADONLYERROR The actual method cannot be executed +''' NOCURRENTRECORDERROR The current record could not be determined +''' Examples +''' dataset.Delete() + +Dim bDelete As Boolean ' Return value +Dim bLast As Boolean ' True when the current record is the last one +Const cstThisSub = "SFDatabases.Dataset.Delete" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bDelete = False + + With _RowSet + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If _ReadOnly Then GoTo CatchreadOnly + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent + +Try: + bLast = .isLast() + .deleteRow() + bDelete = .rowDeleted + If bLast Then .afterLast() Else .next() + + End With + +Finally: + Delete = bDelete + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCurrent: + ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR) + GoTo Finally +CatchReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Dataset.Delete + +REM ----------------------------------------------------------------------------- +Public Function ExportValueToFile(Optional ByVal FieldName As Variant _ + , Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Export the content of a binary field to a given file +''' Args: +''' FieldName: the name of a binary field as a case-sensitive string +''' FileName: the destination file name in ScriptForge.FileSystem service notation +''' Overwrite: when True, the destination file may be overwritten +''' Returns: +''' True when successful +''' Exceptions: +''' NOCURRENTRECORDERROR The current record could not be determined +''' FIELDEXPORTERROR The destination has its readonly attribute set or overwriting rejected + +Dim bExport As Variant ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim lColIndex As Long ' Column index +Dim oColumn As Object ' com.sun.star.sdb.ODataColumn +Dim oStream As Object ' com.sun.star.io.XInputStream +Const cstThisSub = "SFDatabases.Dataset.ExportValueToFile" +Const cstSubArgs = "FieldName, FileName, [Overwrite=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExport = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(FieldName, "FieldName", V_STRING, _Fields) Then GoTo Catch + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check destination file overwriting + sFile = ConvertToUrl(FileName) + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.exists(sFile) Then + If Not Overwrite Then GoTo CatchFile + If oSfa.isReadonly(sFile) Then GoTo CatchFile + End If + + ' Check the current record + With _RowSet + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent + End With + +Try: + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, FieldName, CaseSensitive := True) + If lColIndex >= 0 Then + + ' Establish the input stream + Set oColumn = _RowSet.Columns.getByIndex(lColIndex) + With com.sun.star.sdbc.DataType + Select Case oColumn.Type + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oStream = oColumn.getBinaryStream() + 'Case .VARCHAR, .LONGVARCHAR, .CLOB + Case Else + Set oStream = Nothing + End Select + End With + + ' Process NULL value + If Not IsNull(oStream) And oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then + If oColumn.wasNull() Then + oStream.closeInput() + Set oStream = Nothing + End If + End If + + ' Dump field into file + If Not IsNull(oStream) Then + If oStream.getLength() > 0 Then + oSfa.writeFile(sFile, oStream) + End If + oStream.closeInput() + End If + End If + + bExport = True + +Finally: + ExportValueToFile = bExport + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCurrent: + ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR) + GoTo Finally +CatchFile: + ScriptForge.SF_Exception.RaiseFatal(FIELDEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) + GoTo Finally +End Function ' SFDatabases.SF_Dataset.ExportValueToFile + +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 propRATTCerty +''' If the property does not exist, returns Null + +Const cstThisSub = "SFDatabases.Dataset.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_Dataset.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetRows(Optional ByVal Header As Variant _ + , Optional ByVal MaxRows As Variant _ + ) As Variant +''' Return the content of the dataset as an array +''' This operation can be done in chunks: +''' - The collected data starts at the current row + 1 +''' - When MaxRows > 0 then the collection stops after this limit has been reached. +''' Otherwise all the data up to the end is collected. +''' Args: +''' Header: When True, a header row is inserted at the top of the array with the column names. Default = False +''' MaxRows: The maximum number of returned rows. If absent, all records up to the end 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, lMaxRows As Long +''' lMaxRows = 100 +''' Do +''' a = dataset.GetRows(Header := True, MaxRows := lMaxRows) +''' If UBound(a, 1) >= 0 Then +''' ' ... +''' End If +''' Loop Until UBound(a, 1) < lMaxRows ' Includes empty array - Use ... < lMaxRows - 1 when Header := False + +Dim vResult As Variant ' Return value +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.Dataset.GetRows" +Const cstSubArgs = "[Header=False], [MaxRows=0]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Array() + +Check: + 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(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + If MaxRows < 0 Then MaxRows = 1 + +Try: + With _RowSet + + ' Check if there is any data to collect + bRead = .next() + + If bRead Then + '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 + Do While bRead + 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) = _ParentDatabase._GetColumnValue(_RowSet, i + 1) + Next i + If MaxRows = 0 Or lRows < MaxRows - 1 Then bRead = .next() Else bRead = False + Loop + + Else + vResult = Array() + End If + + End With + +Finally: + GetRows = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.GetRows + +REM ----------------------------------------------------------------------------- +Public Function GetValue(Optional ByVal FieldName As Variant) As Variant +''' Returns the value of a given field in the current record +''' Args: +''' FieldName: the name of a field as a case-sensitive string +''' Returns: +''' The found value as a Basic variable +''' The length of binary fields is returned,not their content. +''' Exceptions: +''' NOCURRENTRECORDERROR The current record could not be determined + +Dim vValue As Variant ' Return value +Dim lColIndex As Long ' Column index +Const cstThisSub = "SFDatabases.Dataset.GetValue" +Const cstSubArgs = "FieldName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vValue = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(FieldName, "FieldName", V_STRING, _Fields) Then GoTo Catch + End If + + With _RowSet + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent + End With + +Try: + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, FieldName, CaseSensitive := True) + If lColIndex >= 0 Then vValue = _ParentDatabase._GetColumnValue(_RowSet, lColIndex + 1) + +Finally: + GetValue = vValue + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCurrent: + ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR) + GoTo Finally +End Function ' SFDatabases.SF_Dataset.GetValue + +REM ----------------------------------------------------------------------------- +Public Function Insert(ParamArray pvArgs As Variant) As Long +''' Create a new record in the database and initialize its fields. +''' The current record is unchanged. The new record is inserted at the end of the dataset. +''' Updatable fields not mentioned in the arguments are initialized with their default value. +''' Args: +''' Either a single argument +''' UpdatesList: a ScriptForge.SF_Dictionary object listing pairs of key/item where +''' the key = an updatable field +''' the item = its value +''' or an even number of arguments alternating +''' FieldName: an updatable field +''' FieldValue: its value +''' The first form is particularly convenient in Python scripts +''' Returns: +''' When the primary key is an AutoValue field: the autovalue of the new record +''' (to facilitate the use of the new primary key in foreign keys) +''' Otherwise: 0 (= successful), -1 (= not successful) +''' Exceptions: +''' DBREADONLYERROR The actual method cannot be executed +''' RECORDUPDATEERROR When value to store does not fit the type of the field +''' or when field is not nullable and value = Null +''' or when field is not writable or is an autovalue +''' or when input file does not exist or is empty +''' or when field type is not supported +''' TABLEPRIMARYKEYERROR Primary key duplication +''' Examples +''' (Basic) +''' Dim newID As Long +''' newID = dataset.Insert("LastName", "Doe", "FirstName", "John") +''' ' ... is equivalent to: +''' Dim dict As Object, newID As Long +''' Set dict = CreateScriptService("ScriptForge.Dictionary") +''' dict.Add("LastName", "Doe") +''' dict.Add("FirstName", "John") +''' newID = dataset.Insert(dict) +''' (Python) - next statements are equivalent +''' newid = dataset.Insert('LastName', 'Doe', 'FirstName', 'John') +''' newid = dataset.Insert({'LastName': 'Doe', 'FirstName': 'John'}) +''' newid = dataset.Insert(dict(LastName = 'Doe', FirstName = 'John')) +''' newid = dataset.Insert(LastName = 'Doe', FirstName = 'John') + +Dim lInsert As Long ' Return value +Dim sSubArgs As String ' Alias of cstSubArgs +Dim sField As String ' A single field name +Dim oUpdates As Object ' A SF_Dictionary object +Dim lColIndex As Long ' Column index +Dim vKeys As Variant ' List of keys in the dictionary +Dim sKey As String ' A single key in vKeys +Dim i As Long +Const cstThisSub = "SFDatabases.Dataset.Insert" +Const cstSubArgs1 = "UpdatesList" +Const cstSubArgs2 = "FieldName1, FieldValue1, [FieldName2, FieldValue2], ..." + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + lInsert = -1 + +Check: + If UBound(pvArgs) = 0 Then ' Dictionary case + sSubArgs = cstSubArgs1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(pvArgs(0), "UpdatesList", ScriptForge.V_OBJECT) Then GoTo Catch + End If + Set oUpdates = pvArgs(0) + Else + sSubArgs = cstSubArgs2 ' Arguments list case + ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) + For i = 0 To UBound(pvArgs) Step 2 + If Not ScriptForge.SF_Utils._Validate(pvArgs(i), "FieldName" & i, V_STRING, _UpdatableFields) Then GoTo Catch + Next i + End If + + If _ReadOnly Then GoTo CatchReadOnly + +Try: + With _RowSet + + ' Initialize the insertion row + .moveToInsertRow() + ' Initial storage of default values + For Each sField In _UpdatableFields + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sField, CaseSensitive := True) + _SetColumnValue(lColIndex, _DefaultValues(lColIndex)) + Next sField + + If UBound(pvArgs) = 0 Then + With oUpdates + vKeys = .Keys + For Each sKey in vKeys + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sKey, CaseSensitive := True) + If lColIndex >= 0 Then + _SetColumnValue(lColIndex, .Item(sKey)) + Else ' To force an error + If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch + End If + Next sKey + End With + Else + For i = 0 To UBound(pvArgs) Step 2 + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, pvArgs(i), CaseSensitive := True) + If lColIndex >= 0 Then + If i < UBound(pvArgs) Then _SetColumnValue(lColIndex, pvArgs(i + 1)) + Else ' To force an error + If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch + End If + Next i + End If + + .insertRow() + + ' Compute the return value: either 0 or the new content of the pre-identified AUtoValue field + If _AutoValue < 0 Then lInsert = 0 Else lInsert = _ParentDatabase._GetColumnValue(_RowSet, _AutoValue + 1) + + .moveToCurrentRow() + + End With + +Finally: + Insert = lInsert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Dataset.Insert + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "CloseDataset" _ + , "CreateDataset" _ + , "Delete" _ + , "ExportValueToFile" _ + , "GetRows" _ + , "GetValue" _ + , "Insert" _ + , "MoveFirst" _ + , "MoveLast" _ + , "MoveNext" _ + , "MovePrevious" _ + , "Reload" _ + , "Update" _ + ) + +End Function ' SFDatabases.SF_Dataset.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveFirst() As Boolean +''' Move the cursor to the 1st record +''' Args: +''' Returns: +''' False when the Move was unsuccessful +''' When False the cursor is reset before the first record + +Dim bMove As Boolean ' Return value +Const cstThisSub = "SFDatabases.Dataset.MoveFirst" +Const cstSubArgs = "" + +Check: + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + with _RowSet + bMove = .first() + If Not bMove Then .beforeFirst() + End With + +Finally: + MoveFirst = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.MoveFirst + +REM ----------------------------------------------------------------------------- +Public Function MoveLast() As Boolean +''' Move the cursor to the last record +''' Args: +''' Returns: +''' False when the Move was unsuccessful +''' When False the cursor is reset before the first record + +Dim bMove As Boolean ' Return value +Const cstThisSub = "SFDatabases.Dataset.MoveLast" +Const cstSubArgs = "" + +Check: + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + with _RowSet + bMove = .last() + If Not bMove Then .beforeFirst() + End With + +Finally: + MoveLast = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.MoveLast + +REM ----------------------------------------------------------------------------- +Public Function MoveNext(Optional ByVal Offset As Variant) As Boolean +''' Move the cursor N records forward. Deleted records are skipped. +''' Args: +''' Offset: number of records to go forward (may be negative). Default = 1 +''' Returns: +''' False when the Move was unsuccessful +''' When False the cursor is reset before the first record when Offset > 0, after the last record otherwise +''' Examples: +''' dataset.MoveNext(3) ' 3 records forward +''' dataset.MoveNext(-1) ' equivalent to MovePrevious() + +Dim bMove As Boolean ' Return value +Dim lRow As Long ' Row number +Const cstThisSub = "SFDatabases.Dataset.MoveNext" +Const cstSubArgs = "[Offset=1]" + +Check: + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Catch + End If + +Try: + with _RowSet + Select Case Offset + Case 0 : bMove = True + Case 1 : bMove = .next() + Case -1 : bMove = .previous() + Case > 1 : bMove = .relative(Offset) ' RowSet.relative() stops at boundary when moving forward only !? + Case Else ' < -1 + lRow = .Row() + If lRow > Abs(Offset) Then bMove = .relative(Offset) Else bMove = False + End Select + If bMove Then + If .rowDeleted() Then + If Offset >= 0 Then bMove = MoveNext() Else bMove = MovePrevious() + End If + End If + End With + +Finally: + MoveNext = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.MoveNext + +REM ----------------------------------------------------------------------------- +Public Function MovePrevious(Optional ByVal Offset As Variant) As Boolean +''' Move the cursor N records backward. Deleted records are skipped. +''' Args: +''' Offset: number of records to go backward (may be negative). Default = 1 +''' Returns: +''' False when the Move was unsuccessful +''' When False the cursor is reset before the first record +''' Examples: +''' dataset.MovePrevious(3) ' 3 records backward +''' dataset.MovePrevious(-1) ' equivalent to MoveNext() + +Dim bMove As Boolean ' Return value +Dim lRow As Long ' Row number +Const cstThisSub = "SFDatabases.Dataset.MovePrevious" +Const cstSubArgs = "[Offset=1]" + +Check: + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Catch + End If + +Try: + with _RowSet + Select Case Offset + Case 0 : bMove = True + Case 1 : bMove = .previous() + Case -1 : bMove = .next() + Case < -1 : bMove = .relative(- Offset) ' RowSet.relative() stops at boundary when moving forward only !? + Case Else ' > 1 + lRow = .Row() + If lRow > Offset Then bMove = .relative(- Offset) Else bMove = False + End Select + If bMove Then + If .rowDeleted() Then + If Offset < 0 Then bMove = MoveNext() Else bMove = MovePrevious() + End If + End If + End With + +Finally: + MovePrevious = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.MovePrevious + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Model class as an array + + Properties = Array( _ + "BOF" _ + , "DefaultValues" _ + , "EOF" _ + , "Fields" _ + , "Filter" _ + , "OrderBy" _ + , "ParentDatabase" _ + , "RowCount" _ + , "RowNumber" _ + , "Source" _ + , "SourceType" _ + , "UpdatableFields" _ + , "Values" _ + , "XRowSet" _ + ) + +End Function ' SFDatabases.SF_Dataset.Properties + +REM ----------------------------------------------------------------------------- +Public Function Reload(Optional ByVal Filter As Variant _ + , Optional ByVal OrderBy As Variant _ + ) As Boolean +''' Reload the dataset from the database. +''' Useful in particular after record deletions and insertions. +''' Filter and OrderBy properties may be redefined. +''' The cursor is reset before the first record. +''' Args: +''' Filter: a condition that records must match, expressed +''' as a valid SQL WHERE clause without the WHERE keyword +''' Default: the actual filter is left unchanged. +''' OrderBy: the ordering of the dataset expressed as a valid SQL ORDER BY clause +''' without the ORDER BY keywords. +''' Default: the actual sorting order is left unchanged. +''' Returns: +''' True when successful +''' Exceptions +''' SQLSYNTAX2ERROR The given SQL statement is incorrect +''' Examples: +''' dataset.Reload() ' dataset is refreshed +''' dataset.Reload(Filter := "") ' Suppress the current filter +''' dataset.Reload(Filter := "[Name] LIKE 'A%'") +''' ' Define a new filter +''' dataset.Reload(Filter := "(" & dataset.Filter & ") AND [Name] LIKE 'A%'") +''' ' Combine actual filter with an additional condition + +Dim bReload As Boolean ' Return value +Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements +Const cstThisSub = "SFDatabases.Dataset.Reload" +Const cstSubArgs = "[Filter=""...filter...""], [OrderBy=""...orderby...""]" + + bErrorHandler = ScriptForge.SF_Utils._ErrorHandling() + If bErrorHandler Then On Local Error GoTo Catch + bReload = False + +Check: + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = _Filter + If IsMissing(OrderBy) Or IsEmpty(OrderBy) Then OrderBy = _OrderBy + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + 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: + If Len(Filter) > 0 Then _Filter = _ParentDatabase._ReplaceSquareBrackets(Filter) Else _Filter = "" + If Len(OrderBy) > 0 Then _OrderBy = _ParentDatabase._ReplaceSquareBrackets(OrderBy) Else _OrderBy = "" + With _RowSet + .Filter = _Filter + .ApplyFilter = ( Len(_Filter) > 0 ) + .Order = _OrderBy + If bErrorhandler Then On Local Error GoTo CatchSql + .execute() + End With + + bReload = True + +Finally: + Reload = bReload + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchSql: + On Local Error GoTo 0 + ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAX2ERROR, _Sql, "WHERE " & _Filter, "ORDER BY " & _OrderBy) + GoTo Catch +End Function ' SFDatabases.SF_Dataset.Reload + +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.Dataset.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +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: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Update(ParamArray pvArgs As Variant) As Boolean +''' Updates a set of fields in the current record +''' Args: +''' Either a single argument +''' UpdatesList: a ScriptForge.SF_Dictionary object listing pairs of key/item where +''' the key = an updatable field +''' the item = its new value +''' or an even number of arguments alternating +''' FieldName: an updatable field +''' FieldValue: its new value +''' The first form is particularly convenient in Python scripts +''' Returns: +''' True when successful +''' Exceptions: +''' DBREADONLYERROR The actual method cannot be executed +''' RECORDUPDATEERROR When value to store does not fit the type of the field +''' or when field is not nullable and value = Null +''' or when field is not writable or is an autovalue +''' or when input file does not exist or is empty +''' or when field type is not supported +''' NOCURRENTRECORDERROR The current record could not be determined +''' Examples +''' (Basic) +''' dataset.Update("LastName", "Doe", "FirstName", "John") +''' ' ... is equivalent to: +''' Dim dict As Object +''' Set dict = CreateScriptService("ScriptForge.Dictionary") +''' dict.Add("LastName", "Doe") +''' dict.Add("FirstName", "John") +''' dataset.Update(dict) +''' (Python) - next statements are equivalent +''' dataset.Update({'LastName': 'Doe', 'FirstName': 'John'}) +''' dataset.Update(dict(LastName = 'Doe', FirstName = 'John')) +''' dataset.Update(LastName = 'Doe', FirstName = 'John') + +Dim bUpdate As Boolean ' Return value +Dim sSubArgs As String ' Alias of cstSubArgs +Dim oUpdates As Object ' A SF_Dictionary object +Dim lColIndex As Long ' Column index +Dim vKeys As Variant ' List of keys in the dictionary +Dim sKey As String ' A single key in vKeys +Dim i As Long +Const cstThisSub = "SFDatabases.Dataset.Update" +Const cstSubArgs1 = "UpdatesList" +Const cstSubArgs2 = "FieldName1, FieldValue1, [FieldName2, FieldValue2], ..." + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bUpdate = False + +Check: + If UBound(pvArgs) = 0 Then ' Dictionary case + sSubArgs = cstSubArgs1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(pvArgs(0), "UpdatesList", ScriptForge.V_OBJECT) Then GoTo Catch + End If + Set oUpdates = pvArgs(0) + Else + sSubArgs = cstSubArgs2 ' Arguments list case + ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) + For i = 0 To UBound(pvArgs) Step 2 + If Not ScriptForge.SF_Utils._Validate(pvArgs(i), "FieldName" & i, V_STRING, _UpdatableFields) Then GoTo Catch + Next i + End If + + If _ReadOnly Then GoTo CatchReadOnly + With _RowSet + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent + End With + +Try: + If UBound(pvArgs) = 0 Then + With oUpdates + vKeys = .Keys + For Each sKey in vKeys + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sKey, CaseSensitive := True) + If lColIndex >= 0 Then + _SetColumnValue(lColIndex, .Item(sKey)) + Else ' To force an error + If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch + End If + Next sKey + End With + Else + For i = 0 To UBound(pvArgs) Step 2 + lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, pvArgs(i), CaseSensitive := True) + If lColIndex >= 0 Then + If i < UBound(pvArgs) Then _SetColumnValue(lColIndex, pvArgs(i + 1)) + Else ' To force an error + If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch + End If + Next i + End If + + If _RowSet.IsModified Then _RowSet.updateRow() + bUpdate = True + +Finally: + Update = bUpdate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCurrent: + ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR) + GoTo Finally +CatchReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Dataset.Update + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _ConvertDefaultValue(ByRef poColumn As Object) As Variant +''' Default values of table fields are stored in the Base file or in the database as strings. +''' The actual method converts those strings into a Basic native type. +''' Usage: facilitate the initialization of new records +''' Args: +''' poColumn: a com.sun.star.sdb.ODataColumn UNO object +''' Returns +''' The default value for the column expressed as a string, a number, a date, ... +''' Nullable columns have probably a Null default value. + +Dim sValue As String ' The default value as a string +Dim vValue As Variant ' The default value as a native Basic type +Dim SESSION As Object : Set SESSION = ScriptForge.SF_Session + +Try: + With poColumn + + ' Determine the default value as a string + If SESSION.HasUnoProperty(poColumn, "DefaultValue") Then ' Default value in database set via SQL statement + sValue = .DefaultValue + ElseIf SESSION.HasUnoProperty(poColumn, "ControlDefault") Then ' Default value set in Base via table edition + If IsEmpty(.ControlDefault) Then sValue = "" Else sValue = .ControlDefault + Else + sValue = "" + End If + + ' Convert the string to a native type + If sValue = "" Then ' No default value => Null or Empty + If .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then vValue = Null Else vValue = Empty + Else + vValue = sValue + With com.sun.star.sdbc.DataType + Select Case poColumn.Type + Case .CHAR, .VARCHAR, .LONGVARCHAR + Case .BIT, .BOOLEAN : vValue = CBool( sValue = "1" ) + Case .TINYINT : vValue = CInt(sValue) + Case .SMALLINT, .INTEGER, .BIGINT : vValue = CLng(sValue) + Case .FLOAT : vValue = CSng(sValue) + Case .REAL, .DOUBLE : vValue = CDbl(sValue) + Case .NUMERIC, .DECIMAL + If SESSION.HasUnoProperty(poColumn, "Scale") Then + If poColumn.Scale > 0 Then vValue = CDbl(sValue) + End If + Case .DATE : vValue = DateValue(sValue) + Case .TIME : vValue = TimeValue(sValue) + Case .TIMESTAMP : vValue = DateValue(sValue) + TimeValue(sValue) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Case .CLOB + Case Else + End Select + End With + End If + + End With + +Finally: + _ConvertDefaultValue = vValue + Exit Function +End Function ' SFDatabases.SF_Dataset._ConvertDefaultValue + +REM ----------------------------------------------------------------------------- +Public Function _Initialize() As Boolean +''' Called immediately after instance creation to complete the initial values +''' An eventual error must be trapped in the calling routine to cancel the instance creation +''' Returns: +''' False when Dataset creation is unsuccessful. Typically because of SQL error + +Dim bDataset As Boolean ' Return value +Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements +Dim sFields As String ' Comma-separated list of field names +Dim sUpdatableFields As String ' Comma-separated list of updatable field names +Dim oColumn As Object ' com.sun.star.sdb.ODataColumn +Dim SESSION As Object : Set SESSION = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Session") +Dim i As Long + + bErrorHandler = ScriptForge.SF_Utils._ErrorHandling() + If bErrorHandler Then On Local Error GoTo Catch + +Try: + Set _RowSet = CreateUnoService("com.sun.star.sdb.RowSet") + With _RowSet + Set .ActiveConnection = _ParentDatabase._Connection + .Command = _Sql + Select Case _DatasetType + Case "TABLE" : .CommandType = com.sun.star.sdb.CommandType.TABLE + Case "QUERY" : .CommandType = com.sun.star.sdb.CommandType.QUERY + Case "SQL" : .CommandType = com.sun.star.sdb.CommandType.COMMAND + End Select + + .EscapeProcessing = Not _DirectSql + .Filter = _Filter + .ApplyFilter = ( Len(_Filter) > 0 ) + .order = _OrderBy + If _ReadOnly Then + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED + Else + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED + End If + + If bErrorHandler Then On Local Error GoTo CatchSql + .execute() + + If bErrorHandler Then On Local Error GoTo Catch + ' Collect info about columns: field name, updatable, default value, AutoValue + With .Columns + sFields = "" + sUpdatableFields = "" + ReDim _DefaultValues (0 To .Count - 1) + ' Columns are scanned by index to guarantee that names and indexes are aligned + For i = 0 To .Count - 1 + Set oColumn = .getByIndex(i) + With oColumn + ' Field names + sFields = sFields & "," & .Name + ' Updatable field names + If Not _ReadOnly And .IsWritable And Not .IsAutoIncrement Then sUpdatableFields = sUpdatableFields & "," & .Name + ' Default values + _DefaultValues(i) = _ConvertDefaultValue(oColumn) + ' AutoValue + If _AutoValue < 0 And .IsAutoIncrement Then _AutoValue = i + End With + Next i + If Len(sFields) <= 1 Then _Fields = Array() Else _Fields = Split(Mid(sFields, 2), ",") + If Len(sUpdatableFields) <= 1 Then _UpdatableFields = Array() Else _UpdatableFields = Split(Mid(sUpdatableFields, 2), ",") + End With + End With + + ' Insert the instance in the _Datasets array of the parent database + _DatasetIndex = _ParentDatabase._AddToDatasets([Me]) + + bDataset = ( _DatasetIndex >= 0 ) + +Finally: + _Initialize = bDataset + Exit Function +Catch: + bDataset = False + GoTo Finally +CatchSql: + On Local Error GoTo 0 + ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAX2ERROR, _Sql, "WHERE " & _Filter, "ORDER BY " & _OrderBy) + GoTo Catch +End Function ' SFDatabases.SF_Dataset._Initialize + +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 vBookmark As Variant ' Bookmark on the current record +Dim vValue As Variant ' A single record field value +Dim vValuesDict As Object ' A dictionary (field name, field value) +Dim i As Long + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDatabases.Dataset.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + With _RowSet + Select Case psProperty + Case "BOF" + _PropertyGet = .isBeforeFirst() + Case "DefaultValues" + ' Load the pairs field name / field default value in the dictionary + vValuesDict = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Dictionary") + For i = 0 To UBound(_DefaultValues) + vValuesDict.Add(_Fields(i), _DefaultValues(i)) + Next i + Set _PropertyGet = vValuesDict + Case "EOF" + _PropertyGet = .isAfterLast() + Case "Fields" + _PropertyGet = _Fields + Case "Filter" + _PropertyGet = _Filter + Case "OrderBy" + _PropertyGet = _OrderBy + Case "ParentDatabase" + Set _PropertyGet = _ParentDatabase + Case "RowCount" + If .IsRowCountFinal Then + _PropertyGet = .RowCount + Else + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then vBookmark = Null Else vBookmark = .getBookmark + .last() + _PropertyGet = .RowCount + If IsNull(vBookmark) Then .beforeFirst() Else .moveToBookmark(vBookmark) + End If + Case "RowNumber" + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then _PropertyGet = 0 Else _PropertyGet = .Row + Case "Source" + _PropertyGet = _Command + Case "SourceType" + _PropertyGet = _DatasetType + Case "UpdatableFields" + _PropertyGet = _UpdatableFields + Case "Values" + If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then + Set _PropertyGet = Nothing + Else + ' Load the pairs field name / field value in the dictionary + vValuesDict = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Dictionary") + For i = 0 To UBound(_Fields) + vValue = _ParentDatabase._GetColumnValue(_RowSet, i + 1, False) + vValuesDict.Add(_Fields(i), vValue) + Next i + Set _PropertyGet = vValuesDict + End If + Case "XRowSet" + Set _PropertyGet = _RowSet + Case Else + _PropertyGet = Null + End Select + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDatabases.Dataset.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + bSet = True + Select Case UCase(psProperty) + Case UCase("BOF") + If Not ScriptForge.SF_Utils._Validate(pvValue, "BOF", ScriptForge.V_BOOLEAN) Then GoTo Finally + If pvValue Then _RowSet.beforeFirst() ' Only True is valid + Case UCase("EOF") + If Not ScriptForge.SF_Utils._Validate(pvValue, "EOF", ScriptForge.V_BOOLEAN) Then GoTo Finally + If pvValue Then _RowSet.afterLast() ' Only True is valid + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Dataset._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Dataset instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DATASET]: tablename,base file url" + + _Repr = "[DATASET]: " & _Command & "," & _ParentDatabase._Location + +End Function ' SFDatabases.SF_Dataset._Repr + +REM ----------------------------------------------------------------------------- +Private Function _SetColumnValue(ByVal plColIndex As Long _ + , ByRef pvValue As Variant _ + ) As Boolean +''' Store a value in a given column of the current record +''' The resultset.insertRow() or resultset.updateRow() methods are supposed to be executed in the calling routine +''' The type of the column is found in the resultset's metadata +''' Args: +''' plColIndex: the index of the column to extract the value from. Starts at 0 +''' Read-only columns are ignored. +''' pvValue:the Variant value to store in the column +''' Strings and numbers are supplied respectively as strings or numeric values +''' Dates and times are supplied as Basic dates +''' Null values are supplied as Null +''' Errors or other strange data types are ignored +''' Returns: +''' True when successful +''' Exceptions: +''' RECORDUPDATEERROR when value to store does not fit the type of the field +''' or when field is not nullable and value = Null +''' or when field is not writable or is an autovalue +''' or when input file does not exist or is empty +''' or when field type is not supported + +Dim bSet As Boolean ' Return value +Dim sColumn As String ' Column name +Dim oColumn As Object ' com.sun.star.sdb.DataColumn +Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType +Dim vDateTime As Variant ' com.sun.star.util.DateTime +Dim bNullable As Boolean ' The field is defined as accepting Null values +Dim vTemp As Variant ' Work variable for date and time related conversions +Dim sFile As String ' File name in FileSystem notation +Dim oSimpleFileAccess As Object ' com.sun.star.ucb.SimpleFileAccess +Dim oStream As Object ' com.sun.star.io.XInputStream +Dim lFileLength As Long ' Binary file length in bytes + +Dim UTILS As Object : Set UTILS = ScriptForge.SF_Utils +Dim SESS As Object : Set SESS = ScriptForge.SF_Session + + bSet = False + On Local Error GoTo CatchError + +Check: + Set oColumn = _RowSet.Columns.getByIndex(plColIndex) + sColumn = oColumn.Name + If _ReadOnly Then GoTo CatchError + If Not ScriptForge.SF_Array.Contains(_UpdatableFields, sColumn, CaseSensitive := True) Then GoTo CatchError + +Try: + With com.sun.star.sdbc.DataType + If IsEmpty(pvValue) Then ' An empty default value means not nullable and no default => ignore + ElseIf IsNull(pvValue) Then + If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull() Else Goto CatchError + Else + Select Case oColumn.Type + Case .BIT, .BOOLEAN + If VarType(pvValue) <> UTILS.V_BOOLEAN Then GoTo CatchError + oColumn.updateBoolean(pvValue) + Case .TINYINT + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + If pvValue < -128 Or pvValue > +127 Then Goto CatchError + oColumn.updateShort(CInt(pvValue)) + Case .SMALLINT + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + If pvValue < -32768 Or pvValue > 32767 Then Goto CatchError + oColumn.updateInt(CInt(pvValue)) + Case .INTEGER + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto CatchError + oColumn.updateInt(CLng(pvValue)) + Case .BIGINT + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + oColumn.updateLong(pvValue) ' No proper type conversion for HYPER data type + Case .FLOAT + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then oColumn.updateFloat(CSng(pvValue)) Else Goto CatchError + Case .REAL, .DOUBLE + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then oColumn.updateDouble(CDbl(pvValue)) Else Goto CatchError + oColumn.updateDouble(CDbl(pvValue)) + Case .NUMERIC, .DECIMAL + If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError + If SESS.HasUnoProperty(oColumn, "Scale") Then + If oColumn.Scale > 0 Then + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then oColumn.updateDouble(CDbl(pvValue)) Else Goto CatchError + oColumn.updateDouble(CDbl(pvValue)) + Else + oColumn.updateString(CStr(pvValue)) + End If + Else + Column.updateString(CStr(pvValue)) + End If + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + If VarType(pvValue) <> V_STRING Then GoTo CatchError + If SESS.HasUnoProperty(oColumn, "Precision") Then + If oColumn.Precision > 0 And Len(pvValue) > oColumn.Precision Then Goto CatchError + End If + oColumn.updateString(pvValue) + Case .DATE + If VarType(pvValue) <> V_DATE Then GoTo CatchError + vTemp = New com.sun.star.util.Date + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + End With + oColumn.updateDate(vTemp) + Case .TIME + If VarType(pvValue) <> V_DATE Then GoTo CatchError + vTemp = New com.sun.star.util.Time + With vTemp + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + .NanoSeconds = 0 + End With + oColumn.updateTime(vTemp) + Case .TIMESTAMP + If VarType(pvValue) <> V_DATE Then GoTo CatchError + vTemp = New com.sun.star.util.DaWHEREteTime + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + .NanoSeconds = 0 + End With + oColumn.updateTimestamp(vTemp) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If VarType(pvValue) <> V_STRING Then GoTo CatchError + If Not UTILS._ValidateFile(pvValue, "FieldValue") Then GoTo CatchError + ' Verify file + sFile = ConvertToUrl(pvValue) + oSimpleFileAccess = UTILS._GetUnoService("FileAccess") + If Not oSimpleFileAccess.exists(sFile) Then Goto CatchError + ' Load the binary data + Set oStream = oSimpleFileAccess.openFileRead(sFile) + lFileLength = oStream.getLength() + If lFileLength = 0 Then Goto CatchError ' <<<<<<<<<<<<<<<<< PUT NULL + oColumn.updateBinaryStream(oStream, lFileLength) + oStream.closeInput() + Case Else + Goto CatchError + End Select + End If + End With + + bSet = True + +Finally: + _SetColumnValue = bSet + Exit Function +CatchError: + On Local Error GoTo 0 + ScriptForge.SF_Exception.RaiseFatal(RECORDUPDATEERROR, sColumn, ScriptForge.SF_String.Represent(pvValue), oColumn.TypeName) + GoTo Finally +End Function ' SFDatabases.SF_Dataset._SetColumnValue + +REM ============================================ END OF SFDATABASES.SF_DATASET +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdatabases/SF_Datasheet.xba b/wizards/source/sfdatabases/SF_Datasheet.xba new file mode 100644 index 0000000000..89e66aefd6 --- /dev/null +++ b/wizards/source/sfdatabases/SF_Datasheet.xba @@ -0,0 +1,952 @@ +<?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_Datasheet" 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_Datasheet +''' ============ +''' A datasheet is the visual representation of tabular data produced by a database. +''' In the user interface of LibreOffice it is the result of the opening of +''' a table or a query. In this case the concerned Base document must be open. +''' +''' In the context of ScriptForge, a datasheet may be opened automatically by script code : +''' - either by reproducing the behaviour of the user interface +''' - or at any moment. In this case the Base document may or may not be opened. +''' Additionally, any SELECT SQL statement may define the datasheet display. +''' +''' The proposed API allows for either datasheets (opened manually of by code) in particular +''' to know which cell is selected and its content. +''' +''' Service invocation: +''' 1) From an open Base document +''' Set ui = CreateScriptService("UI") +''' Set oBase = ui.getDocument("/home/user/Documents/myDb.odb") +''' Set oSheet = oBase.OpenTable("Customers") ' or OpenQuery(...) +''' ' May be executed also when the given table is already open +''' 2) Independently from a Base document +''' Set oDatabase = CreateScriptService("Database", "/home/user/Documents/myDb.odb") +''' Set oSheet = oDatabase.OpenTable("Customers") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_datasheet.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DOCUMENTDEADERROR = "DOCUMENTDEADERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object ' Base instance when opened from a Base document by code + ' or Database instance when opened without Base document +Private ObjectType As String ' Must be DATASHEET +Private ServiceName As String + +Private _Component As Object ' com.sun.star.lang.XComponent - org.openoffice.comp.dbu.ODatasourceBrowser +Private _Frame As Object ' com.sun.star.frame.XFrame +Private _ParentBase As Object ' The parent SF_Base instance (may be void) +Private _ParentDatabase As Object ' The parent SF_Database instance (must not be void) +Private _SheetType As String ' TABLE, QUERY or SQL +Private _ParentType As String ' BASE or DATABASE +Private _BaseFileName As String ' URL format of parent Base file +Private _Command As String ' Table name, query name or SQL statement +Private _DirectSql As Boolean ' When True, SQL processed by RDBMS +Private _TabControllerModel As Object ' com.sun.star.awt.XTabControllerModel - com.sun.star.comp.forms.ODatabaseForm +Private _ControlModel As Object ' com.sun.star.awt.XControlModel - com.sun.star.form.OGridControlModel +Private _ControlView As Object ' com.sun.star.awt.XControl - org.openoffice.comp.dbu.ODatasourceBrowser +Private _ColumnHeaders As Variant ' List of column headers as an array of strings + +' Cache for static toolbar descriptions +Private _Toolbars As Object ' SF_Dictionary instance to hold toolbars stored in application or in document + +REM ============================================================ MODULE CONSTANTS + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DATASHEET" + ServiceName = "SFDatabases.Datasheet" + Set _Component = Nothing + Set _Frame = Nothing + Set _ParentBase = Nothing + Set _ParentDatabase = Nothing + _SheetType = "" + _ParentType = "" + _BaseFileName = "" + _Command = "" + _DirectSql = False + Set _TabControllerModel = Nothing + Set _ControlModel = Nothing + Set _ControlView = Nothing + _ColumnHeaders = Array() + Set _Toolbars = Nothing +End Sub ' SFDatabases.SF_Datasheet Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDatabases.SF_Datasheet Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDatabases.SF_Datasheet Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ColumnHeaders() As Variant +''' Returns the list of column headers of the datasheet as an array of strings + ColumnHeaders = _PropertyGet("ColumnHeaders") +End Property ' SFDatabases.SF_Datasheet.ColumnHeaders + +REM ----------------------------------------------------------------------------- +Property Get CurrentColumn() As String +''' Returns the currently selected column by its name + CurrentColumn = _PropertyGet("CurrentColumn") +End Property ' SFDatabases.SF_Datasheet.CurrentColumn + +REM ----------------------------------------------------------------------------- +Property Get CurrentRow() As Long +''' Returns the currently selected row by its number >= 1 + CurrentRow = _PropertyGet("CurrentRow") +End Property ' SFDatabases.SF_Datasheet.CurrentRow + +REM ----------------------------------------------------------------------------- +Property Get DatabaseFileName() As String +''' Returns the file name of the Base file in FSO.FileNaming format + DatabaseFileName = _PropertyGet("DatabaseFileName") +End Property ' SFDatabases.SF_Datasheet.DatabaseFileName + +REM ----------------------------------------------------------------------------- +Property Get Filter() As Variant +''' The Filter is a SQL WHERE clause without the WHERE keyword + Filter = _PropertyGet("Filter") +End Property ' SFDatabases.SF_Datasheet.Filter (get) + +REM ----------------------------------------------------------------------------- +Property Let Filter(Optional ByVal pvFilter As Variant) +''' Set the updatable property Filter +''' Table and field names may be surrounded by square brackets +''' When the argument is the zero-length string, the actual filter is removed + _PropertySet("Filter", pvFilter) +End Property ' SFDatabases.SF_Datasheet.Filter (let) + +REM ----------------------------------------------------------------------------- +Property Get LastRow() As Long +''' Returns the total number of rows +''' The process may imply to move the cursor to the last available row. +''' Afterwards the cursor is reset to the current row. + LastRow = _PropertyGet("LastRow") +End Property ' SFDatabases.SF_Datasheet.LastRow + +REM ----------------------------------------------------------------------------- +Property Get OrderBy() As Variant +''' The Order is a SQL ORDER BY clause without the ORDER BY keywords + OrderBy = _PropertyGet("OrderBy") +End Property ' SFDocuments.SF_Form.OrderBy (get) + +REM ----------------------------------------------------------------------------- +Property Let OrderBy(Optional ByVal pvOrderBy As Variant) +''' Set the updatable property OrderBy +''' Table and field names may be surrounded by square brackets +''' When the argument is the zero-length string, the actual sort is removed + _PropertySet("OrderBy", pvOrderBy) +End Property ' SFDocuments.SF_Form.OrderBy (let) + +REM ----------------------------------------------------------------------------- +Property Get ParentDatabase() As Object +''' Returns the database instance to which the datasheet belongs + Set ParentDatabase = _PropertyGet("ParentDatabase") +End Property ' SFDatabases.SF_Datasheet.ParentDatabase + +REM ----------------------------------------------------------------------------- +Property Get Source() As String +''' Returns the source of the data: table name, query name or sql statement + Source = _PropertyGet("Source") +End Property ' SFDatabases.SF_Datasheet.Source + +REM ----------------------------------------------------------------------------- +Property Get SourceType() As String +''' Returns thetype of source of the data: TABLE, QUERY or SQL + SourceType = _PropertyGet("SourceType") +End Property ' SFDatabases.SF_Datasheet.SourceType + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Object +''' Returns the com.sun.star.lang.XComponent UNO object representing the datasheet + XComponent = _PropertyGet("XComponent") +End Property ' SFDocuments.SF_Document.XComponent + +REM ----------------------------------------------------------------------------- +Property Get XControlModel() As Object +''' Returns the com.sun.star.lang.XControl UNO object representing the datasheet + XControlModel = _PropertyGet("XControlModel") +End Property ' SFDocuments.SF_Document.XControlModel + +REM ----------------------------------------------------------------------------- +Property Get XTabControllerModel() As Object +''' Returns the com.sun.star.lang.XTabControllerModel UNO object representing the datasheet + XTabControllerModel = _PropertyGet("XTabControllerModel") +End Property ' SFDocuments.SF_Document.XTabControllerModel + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Sub Activate() +''' Make the actual datasheet active +''' Args: +''' Returns: +''' Examples: +''' oSheet.Activate() + +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDatabases.Datasheet.Activate" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + +Try: + Set oContainer = _Component.Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SFDatabases.SF_Datasheet.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDatasheet() As Boolean +''' Close the actual datasheet +''' Args: +''' Returns: +''' True when successful +''' Examples: +''' oSheet.CloseDatasheet() + +Dim bClose As Boolean ' Return value +Const cstThisSub = "SFDatabases.Datasheet.CloseDatasheet" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + +Try: + With _TabControllerModel + .ApplyFilter = False + .Filter = "" + .close() + End With + _Frame.close(True) + _Frame.dispose() + Dispose() + bClose = True + +Finally: + CloseDatasheet = bClose + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.CloseDatasheet + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object +''' Create a new menu entry in the datasheet's menubar +''' The menu is not intended to be saved neither in the LibreOffice global environment, nor elsewhere +''' The method returns a SFWidgets.Menu instance. Its methods let define the menu further. +''' Args: +''' MenuHeader: the name/header of the menu +''' Before: the place where to put the new menu on the menubar (string or number >= 1) +''' When not found => last position +''' SubmenuChar: the delimiter used in menu trees. Default = ">" +''' Returns: +''' A SFWidgets.Menu instance or Nothing +''' Examples: +''' Dim oMenu As Object +''' Set oMenu = oDoc.CreateMenu("My menu", Before := "Styles") +''' With oMenu +''' .AddItem("Item 1", Command := ".uno:About") +''' '... +''' .Dispose() ' When definition is complete, the menu instance may be disposed +''' End With +''' ' ... + +Dim oMenu As Object ' return value +Const cstThisSub = "SFDatabases.Datasheet.CreateMenu" +Const cstSubArgs = "MenuHeader, [Before=""""], [SubmenuChar="">""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oMenu = Nothing + +Check: + If IsMissing(Before) Or IsEmpty(Before) Then Before = "" + If IsMissing(SubmenuChar) Or IsEmpty(SubmenuChar) Then SubmenuChar = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Before, "Before", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SubmenuChar, "SubmenuChar", V_STRING) Then GoTo Finally + End If + +Try: + Set oMenu = ScriptForge.SF_Services.CreateScriptService("SFWidgets.Menu", _Component, MenuHeader, Before, SubmenuChar) + +Finally: + Set CreateMenu = oMenu + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Document.CreateMenu + +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 propRATTCerty +''' If the property does not exist, returns Null + +Const cstThisSub = "SFDatabases.Datasheet.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_Datasheet.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetText(Optional ByVal Column As Variant) As String +''' Get the text in the given column of the current row. +''' Args: +''' Column: the name of the column as a string or its position (>= 1). Default = the current column +''' If the argument exceeds the number of columns, the last column is selected. +''' Returns: +''' The text in the cell as a string as how it is displayed +''' Note that the position of the cursor is left unchanged. +''' Examples: +''' oSheet.GetText("ShipCity")) ' Extract the text on the current row from the column "ShipCity" + +Dim sText As String ' Return Text +Dim lCol As Long ' Numeric index of Column in lists of columns +Dim lMaxCol As Long ' Index of last column +Const cstThisSub = "SFDatabases.Datasheet.GetText" +Const cstSubArgs = "[Column=0]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sText = "" + +Check: + If IsMissing(Column) Or IsEmpty(Column) Then Column = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If VarType(Column) <> V_STRING Then + If Not ScriptForge.SF_Utils._Validate(Column, "Column", ScriptForge.V_NUMERIC) Then GoTo Catch + Else + If Not ScriptForge.SF_Utils._Validate(Column, "Column", V_STRING, _ColumnHeaders) Then GoTo Catch + End If + End If + +Try: + ' Position the column - The index to be passed starts at 0 + With _ControlView + If VarType(Column) = V_STRING Then + lCol = ScriptForge.SF_Array.IndexOf(_ColumnHeaders, Column, CaseSensitive := False) + Else + lCol = -1 + If Column >= 1 Then + lMaxCol = .Count - 1 + If Column > lMaxCol + 1 Then lCol = lMaxCol Else lCol = Column - 1 + Else + lCol = .getCurrentColumnPosition() + End If + End If + + If lCol >= 0 Then sText = .getByIndex(lCol).Text + End With + +Finally: + GetText = sText + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.GetText + +REM ----------------------------------------------------------------------------- +Public Function GetValue(Optional ByVal Column As Variant) As Variant +''' Get the value in the given column of the current row. +''' Args: +''' Column: the name of the column as a string or its position (>= 1). Default = the current column +''' If the argument exceeds the number of columns, the last column is selected. +''' Returns: +''' The value in the cell as a valid Basic type +''' Typical types are: STRING, INTEGER, LONG, FLOAT, DOUBLE, DATE, NULL +''' Binary types are returned as a LONG giving their length, not their content +''' An EMPTY return value means that the value could not be retrieved. +''' Note that the position of the cursor is left unchanged. +''' Examples: +''' oSheet.GetValue("ShipCity")) ' Extract the value on the current row from the column "ShipCity" + +Dim vValue As Variant ' Return value +Dim lCol As Long ' Numeric index of Column in lists of columns +Dim lMaxCol As Long ' Index of last column +Const cstThisSub = "SFDatabases.Datasheet.GetValue" +Const cstSubArgs = "[Column=0]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vValue = Empty + +Check: + If IsMissing(Column) Or IsEmpty(Column) Then Column = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If VarType(Column) <> V_STRING Then + If Not ScriptForge.SF_Utils._Validate(Column, "Column", ScriptForge.V_NUMERIC) Then GoTo Catch + Else + If Not ScriptForge.SF_Utils._Validate(Column, "Column", V_STRING, _ColumnHeaders) Then GoTo Catch + End If + End If + +Try: + ' Position the column - The index to be passed starts at 1 + If VarType(Column) = V_STRING Then + lCol = ScriptForge.SF_Array.IndexOf(_ColumnHeaders, Column, CaseSensitive := False) + 1 + Else + With _ControlView + lCol = 0 + If Column >= 1 Then + lMaxCol = .Count + If Column > lMaxCol Then lCol = lMaxCol Else lCol = Column + Else + lCol = .getCurrentColumnPosition() + 1 + End If + End With + End If + + ' The _TabControllerModel acts exactly as a result set, from which the generic _GetColumnValue can extract the searched value + If lCol >= 1 Then vValue = _ParentDatabase._GetColumnValue(_TabControllerModel, lCol) + +Finally: + GetValue = vValue + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.GetValue + +REM ----------------------------------------------------------------------------- +Public Function GoToCell(Optional ByVal Row As Variant _ + , Optional ByVal Column As Variant _ + ) As Boolean +''' Set the cursor on the given row and the given column. +''' If the requested row exceeds the number of available rows, the cursor is set on the last row. +''' If the requested column exceeds the number of available columns, the selected column is the last one. +''' Args: +''' Row: the row number (>= 1) as a numeric value. Default= no change +''' Column: the name of the column as a string or its position (>= 1). Default = the current column +''' Returns: +''' True when successful +''' Examples: +''' oSheet.GoToCell(1000000, "ShipCity")) ' Set the cursor on he last row, column "ShipCity" + +Dim bGoTo As Boolean ' Return value +Dim lCol As Long ' Numeric index of Column in list of columns +Dim lMaxCol As Long ' Index of last column +Const cstThisSub = "SFDatabases.Datasheet.GoToCell" +Const cstSubArgs = "[Row=0], [Column=0]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bGoTo = False + +Check: + If IsMissing(Row) Or IsEmpty(Row) Then Row = 0 + If IsMissing(Column) Or IsEmpty(Column) Then Column = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Row, "Row", ScriptForge.V_NUMERIC) Then GoTo Catch + If VarType(Column) <> V_STRING Then + If Not ScriptForge.SF_Utils._Validate(Column, "Column", ScriptForge.V_NUMERIC) Then GoTo Catch + Else + If Not ScriptForge.SF_Utils._Validate(Column, "Column", V_STRING, _ColumnHeaders) Then GoTo Catch + End If + End If + +Try: + ' Position the row + With _TabControllerModel + If Row <= 0 Then Row = .Row Else .absolute(Row) + ' Does Row exceed the total number of rows ? + If .IsRowCountFinal And Row > .RowCount Then .absolute(.RowCount) + End With + + ' Position the column + With _ControlView + If VarType(Column) = V_STRING Then + lCol = ScriptForge.SF_Array.IndexOf(_ColumnHeaders, Column, CaseSensitive := False) + Else + lCol = -1 + If Column >= 1 Then + lMaxCol = .Count - 1 + If Column > lMaxCol + 1 Then lCol = lMaxCol Else lCol = Column - 1 + End If + End If + If lCol >= 0 Then .setCurrentColumnPosition(lCol) + End With + + bGoTo = True + +Finally: + GoToCell = bGoTo + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.GoToCell + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "Activate" _ + , "CloseDatasheet" _ + , "CreateMenu" _ + , "GetText" _ + , "GetValue" _ + , "GoToCell" _ + , "RemoveMenu" _ + ) + +End Function ' SFDatabases.SF_Datasheet.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Model class as an array + + Properties = Array( _ + "ColumnHeaders" _ + , "CurrentColumn" _ + , "CurrentRow" _ + , "DatabaseFileName" _ + , "Filter" _ + , "LastRow" _ + , "OrderBy" _ + , "ParentDatabase" _ + , "Source" _ + , "SourceType" _ + , "XComponent" _ + , "XControlModel" _ + , "XTabControllerModel" _ + ) + +End Function ' SFDatabases.SF_Datasheet.Properties + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean +''' Remove a menu entry in the document's menubar +''' The removal is not intended to be saved neither in the LibreOffice global environment, nor in the document +''' Args: +''' MenuHeader: the name/header of the menu, without tilde "~", as a case-sensitive string +''' Returns: +''' True when successful +''' Examples: +''' oDoc.RemoveMenu("File") +''' ' ... + +Dim bRemove As Boolean ' Return value +Dim oLayout As Object ' com.sun.star.comp.framework.LayoutManager +Dim oMenuBar As Object ' com.sun.star.awt.XMenuBar or stardiv.Toolkit.VCLXMenuBar +Dim sName As String ' Menu name +Dim iMenuId As Integer ' Menu identifier +Dim iMenuPosition As Integer ' Menu position >= 0 +Dim i As Integer +Const cstTilde = "~" + +Const cstThisSub = "SFDatabases.Datasheet.RemoveMenu" +Const cstSubArgs = "MenuHeader" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRemove = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + End If + +Try: + Set oLayout = _Component.Frame.LayoutManager + Set oMenuBar = oLayout.getElement("private:resource/menubar/menubar").XMenuBar + + ' Search the menu identifier to remove by its name, Mark its position + With oMenuBar + iMenuPosition = -1 + For i = 0 To .ItemCount - 1 + iMenuId = .getItemId(i) + sName = Replace(.getItemText(iMenuId), cstTilde, "") + If MenuHeader= sName Then + iMenuPosition = i + Exit For + End If + Next i + ' Remove the found menu item + If iMenuPosition >= 0 Then + .removeItem(iMenuPosition, 1) + bRemove = True + End If + End With + +Finally: + RemoveMenu = bRemove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.RemoveMenu + +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.Datasheet.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +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: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Toolbars(Optional ByVal ToolbarName As Variant) As Variant +''' Returns either a list of the available toolbar names in the actual document +''' or a Toolbar object instance. +''' [Function identical with SFDocuments.SF_Document.Toolbars()] +''' Args: +''' ToolbarName: the usual name of one of the available toolbars +''' Returns: +''' A zero-based array of toolbar names when the argument is absent, +''' or a new Toolbar object instance from the SF_Widgets library. + +Const cstThisSub = "SFDatabases.Datasheet.Toolbars" +Const cstSubArgs = "[ToolbarName=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(ToolbarName) Or IsEmpty(ToolbarName) Then ToolbarName = "" + If IsNull(_Toolbars) Then _Toolbars = ScriptForge.SF_UI._ListToolbars(_Component) + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If VarType(ToolbarName) = V_STRING Then + If Len(ToolbarName) > 0 Then + If Not ScriptForge.SF_Utils._Validate(ToolbarName, "ToolbarName", V_STRING, _Toolbars.Keys()) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(ToolbarName, "ToolbarName", V_STRING) Then GoTo Finally ' Manage here the VarType error + End If + End If + +Try: + If Len(ToolbarName) = 0 Then + Toolbars = _Toolbars.Keys() + Else + Toolbars = CreateScriptService("SFWidgets.Toolbar", _Toolbars.Item(ToolbarName)) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Databases.SF_Datasheet.Toolbars + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Called immediately after instance creation to complete the initial values +''' An eventual error must be trapped in the calling routine to cancel the instance creation + +Dim iType As Integer ' One of the com.sun.star.sdb.CommandType constants +Dim oColumn As Object ' A single column +Dim oColumnDescriptor As Object ' A single column descriptor +Dim FSO As Object : Set FSO = ScriptForge.SF_FileSystem +Dim i As Long + +Try: + If IsNull([_Parent]) Then _ParentType = "" Else _ParentType = [_Parent].ObjectType + + With _Component + ' The existence of _Component.Selection must be checked upfront + _Command = ScriptForge.SF_Utils._GetPropertyValue(.Selection, "Command") + + iType = ScriptForge.SF_Utils._GetPropertyValue(.Selection, "CommandType") + Select Case iType + Case com.sun.star.sdb.CommandType.TABLE : _SheetType = "TABLE" + Case com.sun.star.sdb.CommandType.QUERY : _SheetType = "QUERY" + Case com.sun.star.sdb.CommandType.COMMAND : _SheetType = "SQL" + End Select + + _BaseFileName = ScriptForge.SF_Utils._GetPropertyValue(.Selection, "DataSourceName") + _DirectSql = Not ScriptForge.SF_Utils._GetPropertyValue(.Selection, "EscapeProcessing") + + ' Useful UNO objects + Set _Frame = .Frame + Set _ControlView = .CurrentControl + Set _TabControllerModel = .com_sun_star_awt_XTabController_getModel() + Set _ControlModel = _ControlView.getModel() + End With + + With _TabControllerModel + ' Retrieve the parent database instance + Select Case _ParentType + Case "BASE" + Set _ParentDatabase = [_Parent].GetDatabase(.User, .Password) + Set _ParentBase = [_Parent] + Case "DATABASE" + Set _ParentDatabase = [_Parent] + Set _ParentBase = Nothing + Case "" ' Derive the DATABASE instance from what can be found in the Component + Set _ParentDatabase = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database" _ + , FSO._ConvertFromUrl(_BaseFileName), , , .User, .Password) + _ParentType = "DATABASE" + Set _ParentBase = Nothing + End Select + ' Load column headers + _ColumnHeaders = .getColumns().getElementNames() + End With + +Finally: + Exit Sub +End Sub ' SFDatabases.SF_Datasheet._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbError As Boolean) As Boolean +''' Returns True if the datasheet has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sName As String ' Used in error message + + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbError) Then pbError = True + +Try: + ' Check existence of datasheet + bAlive = Not IsNull(_Component.ComponentWindow) + +Finally: + If pbError And Not bAlive Then + sName = _Command + Dispose() + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DOCUMENTDEADERROR, sName) + End If + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + GoTo Finally +End Function ' SFDatabases.SF_Datasheet._IsStillAlive + +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 lRow As Long ' Actual row number +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDatabases.Datasheet.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive(False) Then GoTo Finally + + Select Case psProperty + Case "ColumnHeaders" + _PropertyGet = _ColumnHeaders + Case "CurrentColumn" + _PropertyGet = _ColumnHeaders(_ControlView.getCurrentColumnPosition()) + Case "CurrentRow" + _PropertyGet = _TabControllerModel.Row + Case "DatabaseFileName" + _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_BaseFileName) + Case "Filter" + _PropertyGet = _TabControllerModel.Filter + Case "LastRow" + With _TabControllerModel + If .IsRowCountFinal Then + _PropertyGet = .RowCount + Else + lRow = .Row + If lRow > 0 Then + .last() + _PropertyGet = .RowCount + .absolute(lRow) + Else + _PropertyGet = 0 + End If + End If + End With + Case "OrderBy" + _PropertyGet = _TabControllerModel.Order + Case "ParentDatabase" + Set _PropertyGet = _ParentDatabase + Case "Source" + _PropertyGet = _Command + Case "SourceType" + _PropertyGet = _SheetType + Case "XComponent" + Set _PropertyGet = _Component + Case "XControlModel" + Set _PropertyGet = _ControlModel + Case "XTabControllerModel" + Set _PropertyGet = _TabControllerModel + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDatabases.Datasheet.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + bSet = True + Select Case UCase(psProperty) + Case UCase("Filter") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Filter", V_STRING) Then GoTo Finally + With _TabControllerModel + If Len(pvValue) > 0 Then .Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue) Else .Filter = "" + .ApplyFilter = ( Len(pvValue) > 0 ) + .reload() + End With + Case UCase("OrderBy") + If Not ScriptForge.SF_Utils._Validate(pvValue, "OrderBy", V_STRING) Then GoTo Finally + With _TabControllerModel + If Len(pvValue) > 0 Then .Order = _ParentDatabase._ReplaceSquareBrackets(pvValue) Else .Order = "" + .reload() + End With + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Datasheet._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Datasheet instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DATASHEET]: tablename,base file url" + + _Repr = "[DATASHEET]: " & _Command & "," & _BaseFileName + +End Function ' SFDatabases.SF_Datasheet._Repr + +REM ============================================ END OF SFDATABASES.SF_DATASHEET +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdatabases/SF_Register.xba b/wizards/source/sfdatabases/SF_Register.xba new file mode 100644 index 0000000000..e1b752f7f1 --- /dev/null +++ b/wizards/source/sfdatabases/SF_Register.xba @@ -0,0 +1,280 @@ +<?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_Register" 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 Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" +Private Const DBCONNECTERROR = "DBCONNECTERROR" + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Database", "SFDatabases.SF_Register._NewDatabase") ' Reference to the function initializing the service + .RegisterService("DatabaseFromDocument", "SFDatabases.SF_Register._NewDatabaseFromSource") + .RegisterService("Datasheet", "SFDatabases.SF_Register._NewDatasheet") + End With + +End Sub ' SFDatabases.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _NewDatabase(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_Database class +''' Args: +''' FileName : the name of the file (compliant with the SF_FileSystem.FileNaming notation) +''' RegistrationName: mutually exclusive with FileName. Used when database is registered +''' ReadOnly : (boolean). Default = True +''' User : connection parameters +''' Password +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' BASEDOCUMENTOPENERROR The database file could not be opened +''' DBCONNECTERROR The database could not be connected, credentials are probably wrong + +Dim oDatabase As Object ' Return value +Dim vFileName As Variant ' alias of pvArgs(0) +Dim vRegistration As Variant ' Alias of pvArgs(1) +Dim vReadOnly As Variant ' Alias of pvArgs(2) +Dim vUser As Variant ' Alias of pvArgs(3) +Dim vPassword As Variant ' Alias of pvArgs(4) +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Const cstService = "SFDatabases.Database" +Const cstGlobal = "GlobalScope" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vFileName = pvArgs(0) Else vFileName = "" + If IsEmpty(vFileName) Then vFileName = "" + If UBound(pvArgs) >= 1 Then vRegistration = pvArgs(1) Else vRegistration = "" + If IsEmpty(vRegistration) Then vRegistration = "" + If UBound(pvArgs) >= 2 Then vReadOnly = pvArgs(2) Else vReadOnly = True + If IsEmpty(vReadOnly) Then vReadOnly = True + If UBound(pvArgs) >= 3 Then vUser = pvArgs(3) Else vUser = "" + If IsEmpty(vUser) Then vUser = "" + If UBound(pvArgs) >= 4 Then vPassword = pvArgs(4) Else vPassword = "" + If IsEmpty(vPassword) Then vPassword = "" + If Not ScriptForge.SF_Utils._Validate(vFileName, "FileName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vRegistration, "RegistrationName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vReadOnly, "ReadOnly", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vUser, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vPassword, "Password", V_STRING) Then GoTo Finally + Set oDatabase = Nothing + + ' Check the existence of FileName + With ScriptForge + Set oDBContext = .SF_Utils._GetUNOService("DatabaseContext") + If Len(vFileName) = 0 Then ' FileName has precedence over RegistrationName + If Len(vRegistration) = 0 Then GoTo CatchError + If Not oDBContext.hasRegisteredDatabase(vRegistration) Then GoTo CatchError + vFileName = .SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(vRegistration)) + End If + If Not .SF_FileSystem.FileExists(vFileName) Then GoTo CatchError + End With + +Try: + ' Create the database Basic object and initialize attributes + Set oDatabase = New SF_Database + With oDatabase + Set .[Me] = oDatabase + ._Location = ConvertToUrl(vFileName) + Set ._DataSource = oDBContext.getByName(._Location) + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchConnect + Set ._Connection = ._DataSource.getConnection(vUser, vPassword) + If IsNull(._Connection) Then GoTo CatchConnect + ._User = vUser + ._Password = vPassword + ._ReadOnly = vReadOnly + Set ._MetaData = ._Connection.MetaData + ._URL = ._MetaData.URL + End With + +Finally: + Set _NewDatabase = oDatabase + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", vFileName, "RegistrationName", vRegistration) + GoTo Finally +CatchConnect: + ScriptForge.SF_Exception.RaiseFatal(DBCONNECTERROR, "User", vUser, "Password", vPassword, vFileName) + GoTo Finally +End Function ' SFDatabases.SF_Register._NewDatabase + +REM ----------------------------------------------------------------------------- +Public Function _NewDatabaseFromSource(Optional ByVal pvArgs As Variant) As Object +' ByRef oDataSource As Object _ +' , ByVal sUser As String _ +' , ByVal sPassword As String _ +' ) As Object +''' Create a new instance of the SF_Database class from the given datasource +''' established in the SFDocuments.Base service +''' THIS SERVICE MUST NOT BE CALLED FROM A USER SCRIPT +''' Args: +''' oDataSource: com.sun.star.sdbc.XDataSource +''' sUser, sPassword : connection parameters +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' managed in the calling routines when Nothing is returned + +Dim oDatabase As Object ' Return value +Dim oConnection As Object ' com.sun.star.sdbc.XConnection +Dim oDataSource As Object ' Alias of pvArgs(0) +Dim sUser As String ' Alias of pvArgs(1) +Dim sPassword As String ' Alias of pvArgs(2) + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDatabase = Nothing + +Try: + ' Get arguments + Set oDataSource = pvArgs(0) + sUser = pvArgs(1) + sPassword = pvArgs(2) + + ' Setup the connection + If oDataSource.IsPasswordRequired Then + Set oConnection = oDataSource.getConnection(sUser, sPassword) + Else + Set oConnection = oDataSource.getConnection("", "") + End If + + ' Create the database Basic object and initialize attributes + If Not IsNull(oConnection) Then + Set oDatabase = New SF_Database + With oDatabase + Set .[Me] = oDatabase + ._Location = "" + Set ._DataSource = oDataSource + Set ._Connection = oConnection + ._ReadOnly = oConnection.isReadOnly() + Set ._MetaData = oConnection.MetaData + ._URL = ._MetaData.URL + End With + End If + +Finally: + Set _NewDatabaseFromSource = oDatabase + Exit Function +Catch: + ScriptForge.SF_Exception.Clear() + GoTo Finally +End Function ' SFDatabases.SF_Register._NewDatabaseFromSource + +REM ----------------------------------------------------------------------------- +Public Function _NewDatasheet(Optional ByVal pvArgs As Variant) As Object +' Optional ByRef poComponent As Object _ +' , Optional ByRef poParent As Object _ +' ) As Object +''' Create a new instance of the SF_Datasheet class +''' Called from +''' base.Datasheets() +''' base.OpenTable() +''' base.OpenQuery() +''' database.OpenTable() +''' database.OpenQuery() +''' database.OpenSql() +''' Args: +''' Component: the component of the new datasheet +''' com.sun.star.lang.XComponent - org.openoffice.comp.dbu.ODatasourceBrowser +''' Parent: the parent SF_Database or SF_Base instance having produced the new datasheet +''' When absent, the SF_Database instance will be derived from the component +''' Returns: +''' The instance or Nothing + +Dim oDatasheet As Object ' Return value +Dim oParent As Object ' The parent SF_Database or SF_Base instance having produced the new datasheet +Dim oComponent As Object ' The component of the new datasheet +Dim oWindow As Object ' ui.Window user-defined type +Dim oUi As Object : Set oUi = ScriptForge.SF_Services.CreateScriptService("ScriptForge.UI") + +Const TABLEDATA = "TableData" +Const QUERYDATA = "QueryData" +Const SQLDATA = "SqlData" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDatasheet = Nothing + +Check: + ' Get, check and assign arguments + If Not IsArray(pvArgs) Then GoTo Catch + If UBound(pvArgs) >= 0 Then + Set oComponent = pvArgs(0) + End If + If UBound(pvArgs) = 0 Then + Set oParent = Nothing + ElseIf UBound(pvArgs) = 1 Then + Set oParent = pvArgs(1) + Else + GoTo Catch + End If + + ' Check the validity of the proposed window: is it really a datasheet ? Otherwise, do nothing + If IsNull(oComponent) Then GoTo Catch + Set oWindow = oUi._IdentifyWindow(oComponent) + With oWindow + If .DocumentType <> TABLEDATA And .DocumentType <> QUERYDATA And .DocumentType <> SQLDATA Then GoTo Catch + End With + If IsEmpty(oComponent.Selection) Then GoTo Catch + +Try: + Set oDatasheet = New SF_Datasheet + With oDatasheet + Set .[Me] = oDatasheet + Set .[_Parent] = oParent + Set ._Component = oComponent + ' Achieve the initialization + ._Initialize() + End With + +Finally: + Set _NewDatasheet = oDatasheet + Exit Function +Catch: + Set oDatasheet = Nothing + GoTo Finally +End Function ' SFDatabases.SF_Register._NewDatasheet + +REM ============================================== END OF SFDATABASES.SF_REGISTER +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdatabases/__License.xba b/wizards/source/sfdatabases/__License.xba new file mode 100644 index 0000000000..3b0c64d04a --- /dev/null +++ b/wizards/source/sfdatabases/__License.xba @@ -0,0 +1,26 @@ +<?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="__License" script:language="StarBasic" script:moduleType="normal"> +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +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 ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdatabases/dialog.xlb b/wizards/source/sfdatabases/dialog.xlb new file mode 100644 index 0000000000..8b62d721a8 --- /dev/null +++ b/wizards/source/sfdatabases/dialog.xlb @@ -0,0 +1,3 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="SFDatabases" library:readonly="false" library:passwordprotected="false"/>
\ No newline at end of file diff --git a/wizards/source/sfdatabases/script.xlb b/wizards/source/sfdatabases/script.xlb new file mode 100644 index 0000000000..8e12f56515 --- /dev/null +++ b/wizards/source/sfdatabases/script.xlb @@ -0,0 +1,9 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="SFDatabases" library:readonly="false" library:passwordprotected="false"> + <library:element library:name="SF_Register"/> + <library:element library:name="__License"/> + <library:element library:name="SF_Database"/> + <library:element library:name="SF_Datasheet"/> + <library:element library:name="SF_Dataset"/> +</library:library>
\ No newline at end of file |