| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842 |
- <?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>
|
