update
This commit is contained in:
Jane
@@ -0,0 +1,996 @@
|
||||
<?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.
|
||||
'''
|
||||
''' 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"
|
||||
|
||||
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
|
||||
|
||||
REM ============================================================ MODULE CONSTANTS
|
||||
|
||||
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
|
||||
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:
|
||||
With _Connection
|
||||
If Not IsNull(_Connection) Then
|
||||
If ScriptForge.SF_Session.HasUnoMethod(_Connection, "flush") Then .flush()
|
||||
.close()
|
||||
.dispose()
|
||||
End If
|
||||
Dispose()
|
||||
End With
|
||||
|
||||
Finally:
|
||||
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
||||
Exit Sub
|
||||
End Sub
|
||||
|
||||
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
|
||||
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 = oResult.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
|
||||
.first()
|
||||
Do While Not .isAfterLast() 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
|
||||
.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" _
|
||||
, "DAvg" _
|
||||
, "DCount" _
|
||||
, "DLookup" _
|
||||
, "DMax" _
|
||||
, "DMin" _
|
||||
, "DSum" _
|
||||
, "GetRows" _
|
||||
, "OpenQuery" _
|
||||
, "OpenSql" _
|
||||
, "OpenTable" _
|
||||
, "RunSql" _
|
||||
)
|
||||
|
||||
End Function ' SFDatabases.SF_Database.Methods
|
||||
|
||||
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 ' SFDocuments.SF_Base.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 ' SFDocuments.SF_Base.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 ' SFDocuments.SF_Base.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 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 =========================================================== PRIVATE FUNCTIONS
|
||||
|
||||
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 Not oResult.first() Then Goto Finally
|
||||
If oResult.isAfterLast() Then GoTo Finally
|
||||
vResult = _GetColumnValue(oResult, 1, True) ' Force return of binary field
|
||||
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:
|
||||
ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAXERROR, sSql)
|
||||
GoTo Finally
|
||||
Catch:
|
||||
GoTo Finally
|
||||
End Function ' SFDatabases.SF_Database._ExecuteSql
|
||||
|
||||
REM -----------------------------------------------------------------------------
|
||||
Private Function _GetColumnValue(ByRef poResultSet As Object _
|
||||
, ByVal plColIndex As Long _
|
||||
, Optional ByVal pbReturnBinary As Boolean _
|
||||
) 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
|
||||
''' pbReturnBinary: when True, the method returns the content of a binary field,
|
||||
''' as long as its length does not exceed a maximum length.
|
||||
''' Default = False: binary fields are not returned, only their length
|
||||
''' Returns:
|
||||
''' The Variant value found in the column
|
||||
''' Dates and times are returned as Basic dates
|
||||
''' Null values are returned as Null
|
||||
''' 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
|
||||
If IsMissing(pbReturnBinary) Then pbReturnBinary = False
|
||||
|
||||
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 bNullable Then
|
||||
If Not poResultSet.wasNull() Then
|
||||
If Not ScriptForge.SF_Session.HasUNOMethod(oStream, "getLength") Then ' When no recordset
|
||||
lSize = cstMaxBinLength
|
||||
Else
|
||||
lSize = CLng(oStream.getLength())
|
||||
End If
|
||||
If lSize <= cstMaxBinLength And pbReturnBinary Then
|
||||
vValue = Array()
|
||||
oStream.readBytes(vValue, lSize)
|
||||
Else ' Return length of field, not content
|
||||
vValue = lSize
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
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 .OBJECT, .OTHER, .STRUCT : vValue = Null
|
||||
Case .REF : vValue = poResultSet.getRef(plColIndex)
|
||||
Case .TINYINT : vValue = poResultSet.getShort(plColIndex)
|
||||
Case .CHAR, .VARCHAR : vValue = poResultSet.getString(plColIndex)
|
||||
Case .LONGVARCHAR, .CLOB
|
||||
If bNullable Then
|
||||
If Not poResultSet.wasNull() Then vValue = poResultSet.getString(plColIndex)
|
||||
Else
|
||||
vValue = ""
|
||||
End If
|
||||
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
|
||||
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>
|
||||
@@ -0,0 +1,894 @@
|
||||
<?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 trigger 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 oSheet1 = oBase.OpenTable("Customers") ' or OpenQuery(...)
|
||||
''' Set oSheet2 = oBase.Datasheets("Products") ' when the datasheet has been opened manually
|
||||
''' 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
|
||||
|
||||
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()
|
||||
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:
|
||||
_TabControllerModel.close()
|
||||
_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
|
||||
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
|
||||
lCol = 0
|
||||
If Column >= 1 Then
|
||||
lMaxCol = _ControlView.Count
|
||||
If Column > lMaxCol Then lCol = lMaxCol Else lCol = Column
|
||||
End If
|
||||
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 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:
|
||||
SetProperty = _PropertySet(PropertyName, Value)
|
||||
|
||||
Finally:
|
||||
SF_Utils._ExitFunction(cstThisSub)
|
||||
Exit Function
|
||||
Catch:
|
||||
GoTo Finally
|
||||
End Function ' SFDatabases.SF_Datasheet.SetProperty
|
||||
|
||||
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
|
||||
|
||||
' Retrieve the parent database instance
|
||||
With _TabControllerModel
|
||||
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>
|
||||
@@ -0,0 +1,270 @@
|
||||
<?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"
|
||||
|
||||
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 or connected
|
||||
|
||||
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)
|
||||
Set ._Connection = ._DataSource.getConnection(vUser, 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
|
||||
End Function ' SFDatabases.SF_Register._NewDatabase
|
||||
|
||||
REM -----------------------------------------------------------------------------
|
||||
Public Function _NewDatabaseFromSource(Optional ByVal pvArgs As Variant) As Object
|
||||
' ByRef poDataSource As Object _
|
||||
' , ByVal psUser As String _
|
||||
' , ByVal psPassword 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:
|
||||
''' DataSource: com.sun.star.sdbc.XDataSource
|
||||
''' User, Password : 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:
|
||||
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>
|
||||
@@ -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>
|
||||
@@ -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"/>
|
||||
@@ -0,0 +1,8 @@
|
||||
<?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:library>
|
||||
Reference in New Issue
Block a user