842 lines
38 KiB
Java
842 lines
38 KiB
Java
<?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()
|
|
'''
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
|
|
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( _
|
|
"DAvg" _
|
|
, "DCount" _
|
|
, "DLookup" _
|
|
, "DMax" _
|
|
, "DMin" _
|
|
, "DSum" _
|
|
, "GetRows" _
|
|
, "RunSql" _
|
|
)
|
|
|
|
End Function ' SFDatabases.SF_Database.Methods
|
|
|
|
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 iCommandType ' 1 = Table, 2 = Query, 3 = SQL
|
|
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
|
|
''' plColIndex: the index of the column to extract the value from
|
|
''' 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 = Null ' 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(oValue.getLength())
|
|
End If
|
|
If lSize <= cstMaxBinLength And pbReturnBinary Then
|
|
vValue = Array()
|
|
oValue.readBytes(vValue, lSize)
|
|
Else ' Return length of field, not content
|
|
vValue = lSize
|
|
End If
|
|
End If
|
|
End If
|
|
oValue.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 Sub _Initialize()
|
|
''' Complete the object creation process:
|
|
''' - Initialization of private members
|
|
''' - Creation of the dialog graphical interface
|
|
''' - Addition of the new object in the Dialogs buffer
|
|
|
|
Try:
|
|
' Create the graphical interface
|
|
Set _DialogControl = CreateUnoDialog(_DialogProvider)
|
|
Set _DialogModel = _DialogControl.Model
|
|
|
|
' Add dialog reference to cache
|
|
_CacheIndex = SF_Register._AddDialogToCache(_DialogControl, [Me])
|
|
85
|
|
Finally:
|
|
Exit Sub
|
|
End Sub ' SFDatabases.SF_Database._Initialize
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
|
|
''' Return the value of the named property
|
|
''' Args:
|
|
''' psProperty: the name of the property
|
|
|
|
Dim 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> |