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