forked from amazingfate/loongoffice
88a67c50af
The SF_FormDocument service is focused on :
- The orchestration of Base form documents
(aka Base Forms, but this is confusing)
and the identification of and the access to their controls.
- Form documents are always contained in a Base document.
A form document may be opened either:
- via code or user interface from the Base file welcome page
- via code only, without having its Base container opened first
In any mode, a form document can be opened only in 1 single copy.
The FormDocument service is triggered either by
base.OpenFormDocument(...)
database.OpenFormDocument(...)
' Base file may be closed
ui.GetDocument(...)
Specific methods:
CloseDocument()
Forms()
GetDatabase()
PrintOut()
Next methods are inherited from the Document superclass:
Activate()
CreateMenu(), RemoveMenu()
ExportAsPdf()
RunCommand()
SaveCopyAs()
SetPrinter()
As a consequence, next methods remain available
but should be declared as deprecated in the help:
base.CloseFormDocument()
base.Forms()
base.PrintOut()
base.SetPrinter()
Above changes have several more minor impacts :
- beside IsCalc, IsWriter, ... , a new IsFormDocument property
- the UI service identifies open form documents
- a new service means a new entry to register
in the Services catalog
- management of form events has been reviewed
- the connection between Base, FormDocument, Form
and Database services is reinforced
- menus were available on components, now also on sub-components
The new service is available for both Basic and Python user scripts.
It requires in the help
- a new sf_formdocument page
- a review of the sf_base, sf_database, sf_form, sf_ui pages
Change-Id: Ib06d1c4565ca093af2f068fa5b8082082641752e
Reviewed-on: https://gerrit.libreoffice.org/c/core/+/145080
Tested-by: Jean-Pierre Ledure <jp@ledure.be>
Reviewed-by: Jean-Pierre Ledure <jp@ledure.be>
Tested-by: Jenkins
1087 lines
48 KiB
XML
1087 lines
48 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.
|
|
'''
|
|
''' Service invocation and usage:
|
|
''' 1) To access any database at anytime
|
|
''' Dim myDatabase As Object
|
|
''' Set myDatabase = CreateScriptService("SFDatabases.Database", FileName, , [ReadOnly], [User, [Password]])
|
|
''' ' Args:
|
|
''' ' FileName: the name of the Base file compliant with the SF_FileSystem.FileNaming notation
|
|
''' ' RegistrationName: the name of a registered database (mutually exclusive with FileName)
|
|
''' ' ReadOnly: Default = True
|
|
''' ' User, Password: additional connection arguments to the database server
|
|
''' ' ... Run queries, SQL statements, ...
|
|
''' myDatabase.CloseDatabase()
|
|
'''
|
|
''' 2) To access the database related to the current Base document
|
|
''' Dim myDoc As Object, myDatabase As Object, ui As Object
|
|
''' Set ui = CreateScriptService("UI")
|
|
''' Set myDoc = ui.OpenBaseDocument("myDb.odb")
|
|
''' Set myDatabase = myDoc.GetDatabase() ' user and password are supplied here, if needed
|
|
''' ' ... Run queries, SQL statements, ...
|
|
''' myDoc.CloseDocument()
|
|
'''
|
|
''' Detailed user documentation:
|
|
''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_database.html?DbPAR=BASIC
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
|
|
REM ================================================================== EXCEPTIONS
|
|
|
|
Private Const DBREADONLYERROR = "DBREADONLYERROR"
|
|
Private Const SQLSYNTAXERROR = "SQLSYNTAXERROR"
|
|
|
|
REM ============================================================= PRIVATE MEMBERS
|
|
|
|
Private [Me] As Object
|
|
Private [_Parent] As Object
|
|
Private ObjectType As String ' Must be DATABASE
|
|
Private ServiceName As String
|
|
Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource
|
|
Private _Connection As Object ' com.sun.star.sdbc.XConnection
|
|
Private _URL As String ' Text on status bar
|
|
Private _Location As String ' File name
|
|
Private _ReadOnly As Boolean
|
|
Private _MetaData As Object ' com.sun.star.sdbc.XDatabaseMetaData
|
|
|
|
REM ============================================================ MODULE CONSTANTS
|
|
|
|
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
|
|
End Sub ' SFDatabases.SF_Database Constructor
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Sub Class_Terminate()
|
|
Call Class_Initialize()
|
|
End Sub ' SFDatabases.SF_Database Destructor
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Dispose() As Variant
|
|
Call Class_Terminate()
|
|
Set Dispose = Nothing
|
|
End Function ' SFDatabases.SF_Database Explicit Destructor
|
|
|
|
REM ================================================================== PROPERTIES
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get Queries() As Variant
|
|
''' Return the list of available queries in the database
|
|
Queries = _PropertyGet("Queries")
|
|
End Property ' SFDatabases.SF_Database.Queries (get)
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get Tables() As Variant
|
|
''' Return the list of available Tables in the database
|
|
Tables = _PropertyGet("Tables")
|
|
End Property ' SFDatabases.SF_Database.Tables (get)
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get XConnection() As Variant
|
|
''' Return a com.sun.star.sdbc.XConnection UNO object
|
|
XConnection = _PropertyGet("XConnection")
|
|
End Property ' SFDatabases.SF_Database.XConnection (get)
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Property Get XMetaData() As Variant
|
|
''' Return a com.sun.star.sdbc.XDatabaseMetaData UNO object
|
|
XMetaData = _PropertyGet("XMetaData")
|
|
End Property ' SFDatabases.SF_Database.XMetaData (get)
|
|
|
|
REM ===================================================================== METHODS
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Sub CloseDatabase()
|
|
''' Close the current database connection
|
|
|
|
Const cstThisSub = "SFDatabases.Database.CloseDatabase"
|
|
Const cstSubArgs = ""
|
|
|
|
On Local Error GoTo 0 ' Disable useless error checking
|
|
|
|
Check:
|
|
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
|
|
|
|
Try:
|
|
With _Connection
|
|
If Not IsNull(_Connection) Then
|
|
If ScriptForge.SF_Session.HasUnoMethod(_Connection, "flush") Then .flush()
|
|
.close()
|
|
.dispose()
|
|
End If
|
|
Dispose()
|
|
End With
|
|
|
|
Finally:
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Sub
|
|
End Sub
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DAvg(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function AVG() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
|
|
DAvg = _DFunction("Avg", Expression, TableName, Criteria)
|
|
|
|
End Function ' SFDatabases.SF_Database.DAvg
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DCount(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function COUNT() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
|
|
DCount = _DFunction("Count", Expression, TableName, Criteria)
|
|
|
|
End Function ' SFDatabases.SF_Database.DCount
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DLookup(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
, Optional ByVal OrderClause As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function Lookup() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' To order the results, a pvOrderClause may be precised. The 1st record will be retained.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
''' pvOrderClause: an optional order clause incl. "DESC" if relevant
|
|
|
|
DLookup = _DFunction("Lookup", Expression, TableName, Criteria, OrderClause)
|
|
|
|
End Function ' SFDatabases.SF_Database.DLookup
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DMax(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function MAX() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
|
|
DMax = _DFunction("Max", Expression, TableName, Criteria)
|
|
|
|
End Function ' SFDatabases.SF_Database.DMax
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DMin(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function MIN() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
|
|
DMin = _DFunction("Min", Expression, TableName, Criteria)
|
|
|
|
End Function ' SFDatabases.SF_Database.DMin
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function DSum(Optional ByVal Expression As Variant _
|
|
, Optional ByVal TableName As Variant _
|
|
, Optional ByVal Criteria As Variant _
|
|
) As Variant
|
|
''' Compute the aggregate function Sum() on a field or expression belonging to a table
|
|
''' filtered by a WHERE-clause.
|
|
''' Args:
|
|
''' Expression: an SQL expression
|
|
''' TableName: the name of a table
|
|
''' Criteria: an optional WHERE clause without the word WHERE
|
|
|
|
DSum = _DFunction("Sum", Expression, TableName, Criteria)
|
|
|
|
End Function ' SFDatabases.SF_Database.DSum
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
|
|
''' Return the actual value of the given property
|
|
''' Args:
|
|
''' PropertyName: the name of the property as a string
|
|
''' Returns:
|
|
''' The actual value of the property
|
|
''' Exceptions:
|
|
''' ARGUMENTERROR The property does not exist
|
|
''' Examples:
|
|
''' myDatabase.GetProperty("Queries")
|
|
|
|
Const cstThisSub = "SFDatabases.Database.GetProperty"
|
|
Const cstSubArgs = ""
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
GetProperty = Null
|
|
|
|
Check:
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
|
|
End If
|
|
|
|
Try:
|
|
GetProperty = _PropertyGet(PropertyName)
|
|
|
|
Finally:
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database.GetProperty
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function GetRows(Optional ByVal SQLCommand As Variant _
|
|
, Optional ByVal DirectSQL As Variant _
|
|
, Optional ByVal Header As Variant _
|
|
, Optional ByVal MaxRows As Variant _
|
|
) As Variant
|
|
''' Return the content of a table, a query or a SELECT SQL statement as an array
|
|
''' Args:
|
|
''' SQLCommand: a table name, a query name or a SELECT SQL statement
|
|
''' DirectSQL: when True, no syntax conversion is done by LO. Default = False
|
|
''' Ignored when SQLCommand is a table or a query name
|
|
''' Header: When True, a header row is inserted on the top of the array with the column names. Default = False
|
|
''' MaxRows: The maximum number of returned rows. If absent, all records are returned
|
|
''' Returns:
|
|
''' a 2D array(row, column), even if only 1 column and/or 1 record
|
|
''' an empty array if no records returned
|
|
''' Example:
|
|
''' Dim a As Variant
|
|
''' a = myDatabase.GetRows("SELECT [First Name], [Last Name] FROM [Employees] ORDER BY [Last Name]", Header := True)
|
|
|
|
Dim vResult As Variant ' Return value
|
|
Dim oResult As Object ' com.sun.star.sdbc.XResultSet
|
|
Dim oQuery As Object ' com.sun.star.ucb.XContent
|
|
Dim sSql As String ' SQL statement
|
|
Dim bDirect ' Alias of DirectSQL
|
|
Dim lCols As Long ' Number of columns
|
|
Dim lRows As Long ' Number of rows
|
|
Dim oColumns As Object
|
|
Dim i As Long
|
|
Const cstThisSub = "SFDatabases.Database.GetRows"
|
|
Const cstSubArgs = "SQLCommand, [DirectSQL=False], [Header=False], [MaxRows=0]"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vResult = Array()
|
|
|
|
Check:
|
|
If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False
|
|
If IsMissing(Header) Or IsEmpty(Header) Then Header = False
|
|
If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
' Table, query of SQL ? Prepare resultset
|
|
If ScriptForge.SF_Array.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
|
|
sSql = "SELECT * FROM [" & SQLCommand & "]"
|
|
bDirect = True
|
|
ElseIf ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
|
|
Set oQuery = _Connection.Queries.getByName(SQLCommand)
|
|
sSql = oQuery.Command
|
|
bDirect = Not oQuery.EscapeProcessing
|
|
ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then
|
|
sSql = SQLCommand
|
|
bDirect = DirectSQL
|
|
Else
|
|
GoTo Finally
|
|
End If
|
|
|
|
' Execute command
|
|
Set oResult = _ExecuteSql(sSql, bDirect)
|
|
If IsNull(oResult) Then GoTo Finally
|
|
|
|
With oResult
|
|
'Initialize output array with header row
|
|
Set oColumns = oResult.getColumns()
|
|
lCols = oColumns.Count - 1
|
|
If Header Then
|
|
lRows = 0
|
|
ReDim vResult(0 To lRows, 0 To lCols)
|
|
For i = 0 To lCols
|
|
vResult(lRows, i) = oColumns.getByIndex(i).Name
|
|
Next i
|
|
If MaxRows > 0 Then MaxRows = MaxRows + 1
|
|
Else
|
|
lRows = -1
|
|
End If
|
|
|
|
' Load data
|
|
.first()
|
|
Do While Not .isAfterLast() And (MaxRows = 0 Or lRows < MaxRows - 1)
|
|
lRows = lRows + 1
|
|
If lRows = 0 Then
|
|
ReDim vResult(0 To lRows, 0 To lCols)
|
|
Else
|
|
ReDim Preserve vResult(0 To lRows, 0 To lCols)
|
|
End If
|
|
For i = 0 To lCols
|
|
vResult(lRows, i) = _GetColumnValue(oResult, i + 1)
|
|
Next i
|
|
.next()
|
|
Loop
|
|
End With
|
|
|
|
Finally:
|
|
GetRows = vResult
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database.GetRows
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Methods() As Variant
|
|
''' Return the list of public methods of the Database service as an array
|
|
|
|
Methods = Array( _
|
|
"CloseDatabase" _
|
|
, "DAvg" _
|
|
, "DCount" _
|
|
, "DLookup" _
|
|
, "DMax" _
|
|
, "DMin" _
|
|
, "DSum" _
|
|
, "GetRows" _
|
|
, "OpenFormDocument" _
|
|
, "OpenQuery" _
|
|
, "OpenSql" _
|
|
, "OpenTable" _
|
|
, "RunSql" _
|
|
)
|
|
|
|
End Function ' SFDatabases.SF_Database.Methods
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function OpenFormDocument(Optional ByVal FormDocument As Variant) As Object
|
|
''' Open the FormDocument given by its hierarchical name in normal mode
|
|
''' If the form document is already open, the form document is made active
|
|
''' Args:
|
|
''' FormDocument: a valid form document name as a case-sensitive string
|
|
''' When hierarchical, the hierarchy must be rendered with forward slashes ("/")
|
|
''' Returns:
|
|
''' A FormDocument instance or Nothing
|
|
''' Exceptions:
|
|
''' Form name is invalid
|
|
''' Example:
|
|
''' Set oForm = oDb.OpenFormDocument("Folder1/myFormDocument")
|
|
|
|
Dim oOpen As Object ' Return value
|
|
Dim oFormDocuments As Variant ' com.sun.star.comp.dba.ODocumentContainer
|
|
Dim vFormNames As Variant ' Array of all document form names present in the document
|
|
Dim vOpenArgs As Variant ' Array of property values
|
|
Dim oNewForm As Object ' Output of loadComponent()
|
|
Const cstThisSub = "SFDatabases.Database.OpenFormDocument"
|
|
Const cstSubArgs = "FormDocument"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
Set oOpen = Nothing
|
|
|
|
Check:
|
|
' Build list of available FormDocuments recursively with _CollectFormDocuments
|
|
Set oFormDocuments = _Connection.Parent.DataBaseDocument.FormDocuments
|
|
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
vFormNames = Split(_CollectFormDocuments(oFormDocuments), cstToken)
|
|
If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
vOpenArgs = Array(SF_Utils._MakePropertyValue("ActiveConnection", _Connection) _
|
|
, SF_Utils._MakePropertyValue("OpenMode", "open") _
|
|
)
|
|
Set oNewForm = oFormDocuments.loadComponentFromURL(FormDocument, "", 0, vOpenArgs)
|
|
|
|
Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDocuments.FormDocument", oNewForm)
|
|
|
|
Finally:
|
|
Set OpenFormDocument = oOpen
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SF_Databases.SF_Database.OpenFormDocument
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function OpenQuery(Optional ByVal QueryName As Variant) As Object
|
|
''' Open the query given by its name
|
|
''' The datasheet will live independently from any other (typically Base) component
|
|
''' Args:
|
|
''' QueryName: a valid query name as a case-sensitive string
|
|
''' Returns:
|
|
''' A Datasheet class instance if the query could be opened, otherwise Nothing
|
|
''' Exceptions:
|
|
''' Query name is invalid
|
|
''' Example:
|
|
''' oDb.OpenQuery("myQuery")
|
|
|
|
Dim oOpen As Object ' Return value
|
|
Const cstThisSub = "SFDatabases.Database.OpenQuery"
|
|
Const cstSubArgs = "QueryName"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
Set oOpen = Nothing
|
|
|
|
Check:
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(QueryName, "QueryName", V_STRING, Queries) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
Set oOpen = _OpenDatasheet(QueryName, com.sun.star.sdb.CommandType.QUERY _
|
|
, _Connection.Queries.getByName(QueryName).EscapeProcessing)
|
|
|
|
Finally:
|
|
Set OpenQuery = oOpen
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDocuments.SF_Base.OpenQuery
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function OpenSql(Optional ByRef Sql As Variant _
|
|
, Optional ByVal DirectSql As Variant _
|
|
) As Object
|
|
''' Open the datasheet based on a SQL SELECT statement.
|
|
''' The datasheet will live independently from any other (typically Base) component
|
|
''' Args:
|
|
''' Sql: a valid Sql statement as a case-sensitive string.
|
|
''' Identifiers may be surrounded by square brackets
|
|
''' DirectSql: when True, the statement is processed by the targeted RDBMS
|
|
''' Returns:
|
|
''' A Datasheet class instance if it could be opened, otherwise Nothing
|
|
''' Example:
|
|
''' oDb.OpenSql("SELECT * FROM [Customers] ORDER BY [CITY]")
|
|
|
|
Dim oOpen As Object ' Return value
|
|
Const cstThisSub = "SFDatabases.Database.OpenSql"
|
|
Const cstSubArgs = "Sql, [DirectSql=False]"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
Set oOpen = Nothing
|
|
|
|
Check:
|
|
If IsMissing(DirectSql) Or IsEmpty(DirectSql) Then DirectSql = False
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(Sql, "Sql", V_STRING) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(DirectSql, "DirectSql", ScriptForge.V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
Set oOpen = _OpenDatasheet(_ReplaceSquareBrackets(Sql), com.sun.star.sdb.CommandType.COMMAND, Not DirectSql)
|
|
|
|
Finally:
|
|
Set OpenSql = oOpen
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDocuments.SF_Base.OpenSql
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function OpenTable(Optional ByVal TableName As Variant) As Object
|
|
''' Open the table given by its name
|
|
''' The datasheet will live independently from any other (typically Base) component
|
|
''' Args:
|
|
''' TableName: a valid table name as a case-sensitive string
|
|
''' Returns:
|
|
''' A Datasheet class instance if the table could be opened, otherwise Nothing
|
|
''' Exceptions:
|
|
''' Table name is invalid
|
|
''' Example:
|
|
''' oDb.OpenTable("myTable")
|
|
|
|
Dim oOpen As Object ' Return value
|
|
Const cstThisSub = "SFDatabases.Database.OpenTable"
|
|
Const cstSubArgs = "TableName"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
Set oOpen = Nothing
|
|
|
|
Check:
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(TableName, "TableName", V_STRING, Tables) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
Set oOpen = _OpenDatasheet(TableName, com.sun.star.sdb.CommandType.TABLE, True)
|
|
|
|
Finally:
|
|
Set OpenTable = oOpen
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDocuments.SF_Base.OpenTable
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function Properties() As Variant
|
|
''' Return the list or properties of the Database class as an array
|
|
|
|
Properties = Array( _
|
|
"Queries" _
|
|
, "Tables" _
|
|
, "XConnection" _
|
|
, "XMetaData" _
|
|
)
|
|
|
|
End Function ' SFDatabases.SF_Database.Properties
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function RunSql(Optional ByVal SQLCommand As Variant _
|
|
, Optional ByVal DirectSQL As Variant _
|
|
) As Boolean
|
|
''' Execute an action query (table creation, record insertion, ...) or SQL statement on the current database
|
|
''' Args:
|
|
''' SQLCommand: a query name or an SQL statement
|
|
''' DirectSQL: when True, no syntax conversion is done by LO. Default = False
|
|
''' Ignored when SQLCommand is a query name
|
|
''' Exceptions:
|
|
''' DBREADONLYERROR The method is not applicable on a read-only database
|
|
''' Example:
|
|
''' myDatabase.RunSql("INSERT INTO [EMPLOYEES] VALUES(25, 'SMITH', 'John')", DirectSQL := True)
|
|
|
|
Dim bResult As Boolean ' Return value
|
|
Dim oStatement As Object ' com.sun.star.sdbc.XStatement
|
|
Dim oQuery As Object ' com.sun.star.ucb.XContent
|
|
Dim sSql As String ' SQL statement
|
|
Dim bDirect ' Alias of DirectSQL
|
|
Const cstQuery = 2, cstSql = 3
|
|
Const cstThisSub = "SFDatabases.Database.RunSql"
|
|
Const cstSubArgs = "SQLCommand, [DirectSQL=False]"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
bResult = False
|
|
|
|
Check:
|
|
If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally
|
|
End If
|
|
If _ReadOnly Then GoTo Catch_ReadOnly
|
|
|
|
Try:
|
|
' Query of SQL ?
|
|
If ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then
|
|
Set oQuery = _Connection.Queries.getByName(SQLCommand)
|
|
sSql = oQuery.Command
|
|
bDirect = Not oQuery.EscapeProcessing
|
|
ElseIf Not ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then
|
|
sSql = SQLCommand
|
|
bDirect = DirectSQL
|
|
Else
|
|
GoTo Finally
|
|
End If
|
|
|
|
' Execute command
|
|
bResult = _ExecuteSql(sSql, bDirect)
|
|
|
|
Finally:
|
|
RunSql = bResult
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
Catch_ReadOnly:
|
|
ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR)
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database.RunSql
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function SetProperty(Optional ByVal PropertyName As Variant _
|
|
, Optional ByRef Value As Variant _
|
|
) As Boolean
|
|
''' Set a new value to the given property
|
|
''' Args:
|
|
''' PropertyName: the name of the property as a string
|
|
''' Value: its new value
|
|
''' Exceptions
|
|
''' ARGUMENTERROR The property does not exist
|
|
|
|
Const cstThisSub = "SFDatabases.Database.SetProperty"
|
|
Const cstSubArgs = "PropertyName, Value"
|
|
|
|
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
SetProperty = False
|
|
|
|
Check:
|
|
If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
|
|
End If
|
|
|
|
Try:
|
|
Select Case UCase(PropertyName)
|
|
Case Else
|
|
End Select
|
|
|
|
Finally:
|
|
SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database.SetProperty
|
|
|
|
REM =========================================================== PRIVATE FUNCTIONS
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _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 ' SFDocuments.SF_Base._CollectFormDocuments
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _DFunction(ByVal psFunction As String _
|
|
, Optional ByVal pvExpression As Variant _
|
|
, Optional ByVal pvTableName As Variant _
|
|
, Optional ByVal pvCriteria As Variant _
|
|
, Optional ByVal pvOrderClause As Variant _
|
|
) As Variant
|
|
''' Build and execute a SQL statement computing the aggregate function psFunction
|
|
''' on a field or expression pvExpression belonging to a table pvTableName
|
|
''' filtered by a WHERE-clause pvCriteria.
|
|
''' To order the results, a pvOrderClause may be precised.
|
|
''' Only the 1st record will be retained anyway.
|
|
''' Args:
|
|
''' psFunction an optional aggregate function: SUM, COUNT, AVG, LOOKUP
|
|
''' pvExpression: an SQL expression
|
|
''' pvTableName: the name of a table, NOT surrounded with quoting char
|
|
''' pvCriteria: an optional WHERE clause without the word WHERE
|
|
''' pvOrderClause: an optional order clause incl. "DESC" if relevant
|
|
''' (meaningful only for LOOKUP)
|
|
|
|
Dim vResult As Variant ' Return value
|
|
Dim oResult As Object ' com.sun.star.sdbc.XResultSet
|
|
Dim sSql As String ' SQL statement.
|
|
Dim sExpr As String ' For inclusion of aggregate function
|
|
Dim sTarget as String ' Alias of pvExpression
|
|
Dim sWhere As String ' Alias of pvCriteria
|
|
Dim sOrderBy As String ' Alias of pvOrderClause
|
|
Dim sLimit As String ' TOP 1 clause
|
|
Dim sProductName As String ' RDBMS as a string
|
|
Const cstAliasField = "[" & "TMP_ALIAS_ANY_FIELD" & "]" ' Alias field in SQL expression
|
|
Dim cstThisSub As String : cstThisSub = "SFDatabases.SF_Database.D" & psFunction
|
|
Const cstSubArgs = "Expression, TableName, [Criteria=""""], [OrderClause=""""]"
|
|
Const cstLookup = "Lookup"
|
|
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
vResult = Null
|
|
|
|
Check:
|
|
If IsMissing(pvCriteria) Or IsEmpty(pvCriteria) Then pvCriteria = ""
|
|
If IsMissing(pvOrderClause) Or IsEmpty(pvOrderClause) Then pvOrderClause = ""
|
|
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
|
|
If Not ScriptForge.SF_Utils._Validate(pvExpression, "Expression", V_STRING) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(pvTableName, "TableName", V_STRING, Tables) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(pvCriteria, "Criteria", V_STRING) Then GoTo Finally
|
|
If Not ScriptForge.SF_Utils._Validate(pvOrderClause, "OrderClause", V_STRING) Then GoTo Finally
|
|
End If
|
|
|
|
Try:
|
|
If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
|
|
If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
|
|
sLimit = ""
|
|
|
|
pvTableName = "[" & pvTableName & "]"
|
|
|
|
sProductName = UCase(_MetaData.getDatabaseProductName())
|
|
|
|
Select Case sProductName
|
|
Case "MYSQL", "SQLITE"
|
|
If psFunction = cstLookup Then
|
|
sTarget = pvExpression
|
|
sLimit = " LIMIT 1"
|
|
Else
|
|
sTarget = UCase(psFunction) & "(" & pvExpression & ")"
|
|
End If
|
|
sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & psTableName & sWhere & sOrderBy & sLimit
|
|
Case "FIREBIRD (ENGINE12)"
|
|
If psFunction = cstLookup Then sTarget = "FIRST 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")"
|
|
sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy
|
|
Case Else ' Standard syntax - Includes HSQLDB
|
|
If psFunction = cstLookup Then sTarget = "TOP 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")"
|
|
sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy
|
|
End Select
|
|
|
|
' Execute the SQL statement and retain the first column of the first record
|
|
Set oResult = _ExecuteSql(sSql, True)
|
|
If Not IsNull(oResult) And Not IsEmpty(oResult) Then
|
|
If Not oResult.first() Then Goto Finally
|
|
If oResult.isAfterLast() Then GoTo Finally
|
|
vResult = _GetColumnValue(oResult, 1, True) ' Force return of binary field
|
|
End If
|
|
Set oResult = Nothing
|
|
|
|
Finally:
|
|
_DFunction = vResult
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database._DFunction
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _ExecuteSql(ByVal psSql As String _
|
|
, ByVal pbDirect As Boolean _
|
|
) As Variant
|
|
''' Return a read-only Resultset based on a SELECT SQL statement or execute the given action SQL (INSERT, CREATE TABLE, ...)
|
|
''' The method raises a fatal error when the SQL statement cannot be interpreted
|
|
''' Args:
|
|
''' psSql : the SQL statement. Square brackets are replaced by the correct field surrounding character
|
|
''' pbDirect: when True, no syntax conversion is done by LO. Default = False
|
|
''' Exceptions
|
|
''' SQLSYNTAXERROR The given SQL statement is incorrect
|
|
|
|
Dim vResult As Variant ' Return value - com.sun.star.sdbc.XResultSet or Boolean
|
|
Dim oStatement As Object ' com.sun.star.sdbc.XStatement
|
|
Dim sSql As String ' Alias of psSql
|
|
Dim bSelect As Boolean ' True when SELECT statement
|
|
Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements
|
|
|
|
Set vResult = Nothing
|
|
bErrorHandler = ScriptForge.SF_Utils._ErrorHandling()
|
|
If bErrorHandler Then On Local Error GoTo Catch
|
|
|
|
Try:
|
|
sSql = _ReplaceSquareBrackets(psSql)
|
|
bSelect = ScriptForge.SF_String.StartsWith(sSql, "SELECT", CaseSensitive := False)
|
|
|
|
Set oStatement = _Connection.createStatement()
|
|
With oStatement
|
|
If bSelect Then
|
|
.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
|
|
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
|
|
End If
|
|
.EscapeProcessing = Not pbDirect
|
|
|
|
' Setup the result set
|
|
If bErrorHandler Then On Local Error GoTo Catch_Sql
|
|
If bSelect Then Set vResult = .executeQuery(sSql) Else vResult = .execute(sSql)
|
|
End With
|
|
|
|
Finally:
|
|
_ExecuteSql = vResult
|
|
Set oStatement = Nothing
|
|
Exit Function
|
|
Catch_Sql:
|
|
ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAXERROR, sSql)
|
|
GoTo Finally
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database._ExecuteSql
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _GetColumnValue(ByRef poResultSet As Object _
|
|
, ByVal plColIndex As Long _
|
|
, Optional ByVal pbReturnBinary As Boolean _
|
|
) As Variant
|
|
''' Get the data stored in the current record of a result set in a given column
|
|
''' The type of the column is found in the resultset's metadata
|
|
''' Args:
|
|
''' poResultSet: com.sun.star.sdbc.XResultSet or com.sun.star.awt.XTabControllerModel
|
|
''' plColIndex: the index of the column to extract the value from. Starts at 1
|
|
''' pbReturnBinary: when True, the method returns the content of a binary field,
|
|
''' as long as its length does not exceed a maximum length.
|
|
''' Default = False: binary fields are not returned, only their length
|
|
''' Returns:
|
|
''' The Variant value found in the column
|
|
''' Dates and times are returned as Basic dates
|
|
''' Null values are returned as Null
|
|
''' Errors or strange data types are returned as Null as well
|
|
|
|
Dim vValue As Variant ' Return value
|
|
Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType
|
|
Dim vDateTime As Variant ' com.sun.star.util.DateTime
|
|
Dim oStream As Object ' Long character or binary streams
|
|
Dim bNullable As Boolean ' The field is defined as accepting Null values
|
|
Dim lSize As Long ' Binary field length
|
|
|
|
Const cstMaxBinlength = 2 * 65535
|
|
|
|
On Local Error Goto 0 ' Disable error handler
|
|
vValue = Empty ' Default value if error
|
|
If IsMissing(pbReturnBinary) Then pbReturnBinary = False
|
|
|
|
With com.sun.star.sdbc.DataType
|
|
lType = poResultSet.MetaData.getColumnType(plColIndex)
|
|
bNullable = ( poResultSet.MetaData.IsNullable(plColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
|
|
|
Select Case lType
|
|
Case .ARRAY : vValue = poResultSet.getArray(plColIndex)
|
|
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
|
Set oStream = poResultSet.getBinaryStream(plColIndex)
|
|
If bNullable Then
|
|
If Not poResultSet.wasNull() Then
|
|
If Not ScriptForge.SF_Session.HasUNOMethod(oStream, "getLength") Then ' When no recordset
|
|
lSize = cstMaxBinLength
|
|
Else
|
|
lSize = CLng(oStream.getLength())
|
|
End If
|
|
If lSize <= cstMaxBinLength And pbReturnBinary Then
|
|
vValue = Array()
|
|
oStream.readBytes(vValue, lSize)
|
|
Else ' Return length of field, not content
|
|
vValue = lSize
|
|
End If
|
|
End If
|
|
End If
|
|
If Not IsNull(oStream) Then oStream.closeInput()
|
|
Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(plColIndex)
|
|
Case .DATE
|
|
vDateTime = poResultSet.getDate(plColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
|
|
Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
|
|
vValue = Null
|
|
Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(plColIndex)
|
|
Case .FLOAT : vValue = poResultSet.getFloat(plColIndex)
|
|
Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(plColIndex)
|
|
Case .BIGINT : vValue = CLng(poResultSet.getLong(plColIndex))
|
|
Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(plColIndex)
|
|
Case .SQLNULL : vValue = poResultSet.getNull(plColIndex)
|
|
Case .OBJECT, .OTHER, .STRUCT : vValue = Null
|
|
Case .REF : vValue = poResultSet.getRef(plColIndex)
|
|
Case .TINYINT : vValue = poResultSet.getShort(plColIndex)
|
|
Case .CHAR, .VARCHAR : vValue = poResultSet.getString(plColIndex)
|
|
Case .LONGVARCHAR, .CLOB
|
|
If bNullable Then
|
|
If Not poResultSet.wasNull() Then vValue = poResultSet.getString(plColIndex)
|
|
Else
|
|
vValue = ""
|
|
End If
|
|
Case .TIME
|
|
vDateTime = poResultSet.getTime(plColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
|
|
Case .TIMESTAMP
|
|
vDateTime = poResultSet.getTimeStamp(plColIndex)
|
|
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
|
|
+ TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
|
|
Case Else
|
|
vValue = poResultSet.getString(plColIndex) 'GIVE STRING A TRY
|
|
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
|
|
End Select
|
|
If bNullable Then
|
|
If poResultSet.wasNull() Then vValue = Null
|
|
End If
|
|
End With
|
|
|
|
_GetColumnValue = vValue
|
|
|
|
End Function ' SFDatabases.SF_Database.GetColumnValue
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Public Function _OpenDatasheet(Optional ByVal psCommand As Variant _
|
|
, piDatasheetType As Integer _
|
|
, pbEscapeProcessing As Boolean _
|
|
) As Object
|
|
''' Open the datasheet given by its name and its type
|
|
''' The datasheet will live independently from any other component
|
|
''' Args:
|
|
''' psCommand: a valid table or query name or an SQL statement as a case-sensitive string
|
|
''' piDatasheetType: one of the com.sun.star.sdb.CommandType constants
|
|
''' pbEscapeProcessing: == Not DirectSql
|
|
''' Returns:
|
|
''' A Datasheet class instance if the datasheet could be opened, otherwise Nothing
|
|
|
|
Dim oOpen As Object ' Return value
|
|
Dim oNewDatasheet As Object ' com.sun.star.lang.XComponent
|
|
Dim oURL As Object ' com.sun.star.util.URL
|
|
Dim oDispatch As Object ' com.sun.star.frame.XDispatch
|
|
Dim vArgs As Variant ' Array of property values
|
|
|
|
On Local Error GoTo Catch
|
|
Set oOpen = Nothing
|
|
|
|
Try:
|
|
' Setup the dispatcher
|
|
Set oURL = New com.sun.star.util.URL
|
|
oURL.Complete = ".component:DB/DataSourceBrowser"
|
|
Set oDispatch = StarDesktop.queryDispatch(oURL, "_blank", com.sun.star.frame.FrameSearchFlag.CREATE)
|
|
|
|
' Setup the arguments of the component to create
|
|
With ScriptForge.SF_Utils
|
|
vArgs = Array( _
|
|
._MakePropertyValue("ActiveConnection", _Connection) _
|
|
, ._MakePropertyValue("CommandType", piDatasheetType) _
|
|
, ._MakePropertyValue("Command", psCommand) _
|
|
, ._MakePropertyValue("ShowMenu", True) _
|
|
, ._MakePropertyValue("ShowTreeView", False) _
|
|
, ._MakePropertyValue("ShowTreeViewButton", False) _
|
|
, ._MakePropertyValue("Filter", "") _
|
|
, ._MakePropertyValue("ApplyFilter", False) _
|
|
, ._MakePropertyValue("EscapeProcessing", pbEscapeProcessing) _
|
|
)
|
|
End With
|
|
|
|
' Open the targeted datasheet
|
|
Set oNewDatasheet = oDispatch.dispatchWithReturnValue(oURL, vArgs)
|
|
If Not IsNull(oNewDatasheet) Then Set oOpen = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Datasheet", oNewDatasheet, [Me])
|
|
|
|
Finally:
|
|
Set _OpenDatasheet = oOpen
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDocuments.SF_Base._OpenDatasheet
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
|
|
''' Return the value of the named property
|
|
''' Args:
|
|
''' psProperty: the name of the property
|
|
|
|
Dim cstThisSub As String
|
|
Const cstSubArgs = ""
|
|
|
|
cstThisSub = "SFDatabases.Database.get" & psProperty
|
|
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
|
|
|
|
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
|
|
|
|
Select Case psProperty
|
|
Case "Queries"
|
|
If Not IsNull(_Connection) Then _PropertyGet = _Connection.Queries.getElementNames() Else _PropertyGet = Array()
|
|
Case "Tables"
|
|
If Not IsNull(_Connection) Then _PropertyGet = _Connection.Tables.getElementNames() Else _PropertyGet = Array()
|
|
Case "XConnection"
|
|
Set _PropertyGet = _Connection
|
|
Case "XMetaData"
|
|
Set _PropertyGet = _MetaData
|
|
Case Else
|
|
_PropertyGet = Null
|
|
End Select
|
|
|
|
Finally:
|
|
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
|
|
Exit Function
|
|
Catch:
|
|
GoTo Finally
|
|
End Function ' SFDatabases.SF_Database._PropertyGet
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _ReplaceSquareBrackets(ByVal psSql As String) As String
|
|
''' Returns the input SQL command after replacement of square brackets by the table/field names quoting character
|
|
|
|
Dim sSql As String ' Return value
|
|
Dim sQuote As String ' RDBMS specific table/field surrounding character
|
|
Dim sConstQuote As String ' Delimiter for string constants in SQL - usually the single quote
|
|
Const cstDouble = """" : Const cstSingle = "'"
|
|
|
|
Try:
|
|
sQuote = _MetaData.IdentifierQuoteString
|
|
sConstQuote = Iif(sQuote = cstSingle, cstDouble, cstSingle)
|
|
|
|
' Replace the square brackets
|
|
sSql = Join(ScriptForge.SF_String.SplitNotQuoted(psSql, "[", , sConstQuote), sQuote)
|
|
sSql = Join(ScriptForge.SF_String.SplitNotQuoted(sSql, "]", , sConstQuote), sQuote)
|
|
|
|
Finally:
|
|
_ReplaceSquareBrackets = sSql
|
|
Exit Function
|
|
End Function ' SFDatabases.SF_Database._ReplaceSquareBrackets
|
|
|
|
REM -----------------------------------------------------------------------------
|
|
Private Function _Repr() As String
|
|
''' Convert the Database instance to a readable string, typically for debugging purposes (DebugPrint ...)
|
|
''' Args:
|
|
''' Return:
|
|
''' "[DATABASE]: Location (Statusbar)"
|
|
|
|
_Repr = "[DATABASE]: " & _Location & " (" & _URL & ")"
|
|
|
|
End Function ' SFDatabases.SF_Database._Repr
|
|
|
|
REM ============================================ END OF SFDATABASES.SF_DATABASE
|
|
</script:module> |