diff options
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/sfdatabases/SF_Database.xba | 825 |
1 files changed, 825 insertions, 0 deletions
diff --git a/wizards/source/sfdatabases/SF_Database.xba b/wizards/source/sfdatabases/SF_Database.xba new file mode 100644 index 000000000..804084aff --- /dev/null +++ b/wizards/source/sfdatabases/SF_Database.xba @@ -0,0 +1,825 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Database" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDatabases library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Database +''' ========= +''' Management of databases embedded in or related to Base documents +''' Each instance of the current class represents a single database, with essentially its tables, queries and data +''' +''' The exchanges with the database are done in SQL only. +''' To make them more readable, use optionally square brackets to surround table/query/field names +''' instead of the (RDBMS-dependent) normal surrounding character (usually, double-quote, single-quote or other). +''' SQL statements may be run in direct or indirect mode. In direct mode the statement is transferred literally +''' without syntax checking nor review to the database system. +''' +''' The provided interfaces include simple tables, queries and fields lists, and access to database metadata. +''' +''' Service invocation and usage: +''' 1) To access any database at anytime +''' Dim myDatabase As Object +''' Set myDatabase = CreateScriptService("SFDatabases.Database", FileName, , [ReadOnly], [User, [Password]]) +''' ' Args: +''' ' FileName: the name of the Base file compliant with the SF_FileSystem.FileNaming notation +''' ' RegistrationName: the name of a registered database (mutually exclusive with FileName) +''' ' ReadOnly: Default = True +''' ' User, Password: additional connection arguments to the database server +''' ' ... Run queries, SQL statements, ... +''' myDatabase.CloseDatabase() +''' +''' 2) To access the database related to the current Base document +''' Dim myDoc As Object, myDatabase As Object, ui As Object +''' Set ui = CreateScriptService("UI") +''' Set myDoc = ui.OpenBaseDocument("myDb.odb") +''' Set myDatabase = myDoc.GetDatabase() ' user and password are supplied here, if needed +''' ' ... Run queries, SQL statements, ... +''' myDoc.CloseDocument() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_database.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DBREADONLYERROR = "DBREADONLYERROR" +Private Const SQLSYNTAXERROR = "SQLSYNTAXERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DATABASE +Private ServiceName As String +Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource +Private _Connection As Object ' com.sun.star.sdbc.XConnection +Private _URL As String ' Text on status bar +Private _Location As String ' File name +Private _ReadOnly As Boolean +Private _MetaData As Object ' com.sun.star.sdbc.XDatabaseMetaData + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DATABASE" + ServiceName = "SFDatabases.Database" + Set _DataSource = Nothing + Set _Connection = Nothing + _URL = "" + _Location = "" + _ReadOnly = True + Set _MetaData = Nothing +End Sub ' SFDatabases.SF_Database Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDatabases.SF_Database Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDatabases.SF_Database Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Queries() As Variant +''' Return the list of available queries in the database + Queries = _PropertyGet("Queries") +End Property ' SFDatabases.SF_Database.Queries (get) + +REM ----------------------------------------------------------------------------- +Property Get Tables() As Variant +''' Return the list of available Tables in the database + Tables = _PropertyGet("Tables") +End Property ' SFDatabases.SF_Database.Tables (get) + +REM ----------------------------------------------------------------------------- +Property Get XConnection() As Variant +''' Return a com.sun.star.sdbc.XConnection UNO object + XConnection = _PropertyGet("XConnection") +End Property ' SFDatabases.SF_Database.XConnection (get) + +REM ----------------------------------------------------------------------------- +Property Get XMetaData() As Variant +''' Return a com.sun.star.sdbc.XDatabaseMetaData UNO object + XMetaData = _PropertyGet("XMetaData") +End Property ' SFDatabases.SF_Database.XMetaData (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Sub CloseDatabase() +''' Close the current database connection + +Const cstThisSub = "SFDatabases.Database.CloseDatabase" +Const cstSubArgs = "" + + On Local Error GoTo 0 ' Disable useless error checking + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + With _Connection + If Not IsNull(_Connection) Then + If ScriptForge.SF_Session.HasUnoMethod(_Connection, "flush") Then .flush() + .close() + .dispose() + End If + Dispose() + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub + +REM ----------------------------------------------------------------------------- +Public Function DAvg(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function AVG() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DAvg = _DFunction("Avg", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DAvg + +REM ----------------------------------------------------------------------------- +Public Function DCount(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function COUNT() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DCount = _DFunction("Count", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DCount + +REM ----------------------------------------------------------------------------- +Public Function DLookup(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + , Optional ByVal OrderClause As Variant _ + ) As Variant +''' Compute the aggregate function Lookup() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' To order the results, a pvOrderClause may be precised. The 1st record will be retained. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE +''' pvOrderClause: an optional order clause incl. "DESC" if relevant + + DLookup = _DFunction("Lookup", Expression, TableName, Criteria, OrderClause) + +End Function ' SFDatabases.SF_Database.DLookup + +REM ----------------------------------------------------------------------------- +Public Function DMax(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MAX() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMax = _DFunction("Max", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMax + +REM ----------------------------------------------------------------------------- +Public Function DMin(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MIN() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMin = _DFunction("Min", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMin + +REM ----------------------------------------------------------------------------- +Public Function DSum(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function Sum() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DSum = _DFunction("Sum", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DSum + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myDatabase.GetProperty("Queries") + +Const cstThisSub = "SFDatabases.Database.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetRows(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + , Optional ByVal Header As Variant _ + , Optional ByVal MaxRows As Variant _ + ) As Variant +''' Return the content of a table, a query or a SELECT SQL statement as an array +''' Args: +''' SQLCommand: a table name, a query name or a SELECT SQL statement +''' DirectSQL: when True, no syntax conversion is done by LO. Default = False +''' Ignored when SQLCommand is a table or a query name +''' Header: When True, a header row is inserted on the top of the array with the column names. Default = False +''' MaxRows: The maximum number of returned rows. If absent, all records are returned +''' Returns: +''' a 2D array(row, column), even if only 1 column and/or 1 record +''' an empty array if no records returned +''' Example: +''' Dim a As Variant +''' a = myDatabase.GetRows("SELECT [First Name], [Last Name] FROM [Employees] ORDER BY [Last Name]", Header := True) + +Dim vResult As Variant ' Return value +Dim oResult As Object ' com.sun.star.sdbc.XResultSet +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim sSql As String ' SQL statement +Dim bDirect ' Alias of DirectSQL +Dim lCols As Long ' Number of columns +Dim lRows As Long ' Number of rows +Dim oColumns As Object +Dim i As Long +Const cstThisSub = "SFDatabases.Database.GetRows" +Const cstSubArgs = "SQLCommand, [DirectSQL=False], [Header=False], [MaxRows=0]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Array() + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If IsMissing(Header) Or IsEmpty(Header) Then Header = False + If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Table, query of SQL ? Prepare resultset + If ScriptForge.SF_Array.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + sSql = "SELECT * FROM [" & SQLCommand & "]" + bDirect = True + ElseIf ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + sSql = oQuery.Command + bDirect = Not oQuery.EscapeProcessing + ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sSql = SQLCommand + bDirect = DirectSQL + Else + GoTo Finally + End If + + ' Execute command + Set oResult = _ExecuteSql(sSql, bDirect) + If IsNull(oResult) Then GoTo Finally + + With oResult + 'Initialize output array with header row + Set oColumns = oResult.getColumns() + lCols = oColumns.Count - 1 + If Header Then + lRows = 0 + ReDim vResult(0 To lRows, 0 To lCols) + For i = 0 To lCols + vResult(lRows, i) = oColumns.getByIndex(i).Name + Next i + If MaxRows > 0 Then MaxRows = MaxRows + 1 + Else + lRows = -1 + End If + + ' Load data + .first() + Do While Not .isAfterLast() And (MaxRows = 0 Or lRows < MaxRows - 1) + lRows = lRows + 1 + If lRows = 0 Then + ReDim vResult(0 To lRows, 0 To lCols) + Else + ReDim Preserve vResult(0 To lRows, 0 To lCols) + End If + For i = 0 To lCols + vResult(lRows, i) = _GetColumnValue(oResult, i + 1) + Next i + .next() + Loop + End With + +Finally: + GetRows = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetRows + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Database service as an array + + Methods = Array( _ + "CloseDatabase" _ + , "DAvg" _ + , "DCount" _ + , "DLookup" _ + , "DMax" _ + , "DMin" _ + , "DSum" _ + , "GetRows" _ + , "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 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 ----------------------------------------------------------------------------- +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>
\ No newline at end of file |