mirror of
https://gitee.com/kekingcn/file-online-preview.git
synced 2026-03-16 22:23:46 +08:00
更新windows内置office目录名, 适配jodconverter
This commit is contained in:
陈精华
842
server/libreoffice/share/basic/SFDatabases/SF_Database.xba
Normal file
842
server/libreoffice/share/basic/SFDatabases/SF_Database.xba
Normal file
@@ -0,0 +1,842 @@
|
||||
<?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>
|
||||
Reference in New Issue
Block a user