bc5cdd2413
The invocation of CloseConnection has next effects:
All the recordsets related to a database linked to the current document are closed.
The database object(s) is(are) released.
Change-Id: I845b27acb8469c4dea0dc3bc20b912ab123d06cf
969 lines
No EOL
38 KiB
XML
969 lines
No EOL
38 KiB
XML
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
|
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Database" script:language="StarBasic">REM =======================================================================================================================
|
|
REM === The Access2Base library is a part of the LibreOffice project. ===
|
|
REM === Full documentation is available on http://www.access2base.com ===
|
|
REM =======================================================================================================================
|
|
|
|
Option Compatible
|
|
Option ClassModule
|
|
|
|
Option Explicit
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS ROOT FIELDS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Private _Type As String ' Must be DATABASE
|
|
Private _This As Object ' Workaround for absence of This builtin function
|
|
Private _DbConnect As Integer ' DBCONNECTxxx constants
|
|
Private Title As String
|
|
Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
|
|
Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection
|
|
Private URL As String
|
|
Private _ReadOnly As Boolean
|
|
Private MetaData As Object ' interface XDatabaseMetaData
|
|
Private Form As Object ' com.sun.star.form.XForm
|
|
Private FormName As String
|
|
Private RecordsetMax As Integer
|
|
Private RecordsetsColl As Object ' Collection of active recordsets
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Sub Class_Initialize()
|
|
_Type = OBJDATABASE
|
|
Set _This = Nothing
|
|
_DbConnect = 0
|
|
Title = ""
|
|
Set Document = Nothing
|
|
Set Connection = Nothing
|
|
URL = ""
|
|
_ReadOnly = False
|
|
Set MetaData = Nothing
|
|
Set Form = Nothing
|
|
FormName = ""
|
|
RecordsetMax = 0
|
|
Set RecordsetsColl = New Collection
|
|
End Sub ' Constructor
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Sub Class_Terminate()
|
|
On Local Error Resume Next
|
|
Call CloseAllRecordsets()
|
|
If _DbConnect <> DBCONNECTANY Then
|
|
If Not IsNull(Connection) Then
|
|
Connection.close()
|
|
Connection.dispose()
|
|
Set Connection = Nothing
|
|
End If
|
|
Else
|
|
mClose()
|
|
End If
|
|
Call Class_Initialize()
|
|
End Sub ' Destructor
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub Dispose()
|
|
Call Class_Terminate()
|
|
End Sub ' Explicit destructor
|
|
|
|
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS GET/LET/SET PROPERTIES ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Property Get ObjectType() As String
|
|
ObjectType = _PropertyGet("ObjectType")
|
|
End Property ' ObjectType (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS METHODS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function mClose() As Variant
|
|
' Close the database
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "Database.Close"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
mClose = False
|
|
If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable
|
|
|
|
Connection.close()
|
|
Connection.dispose()
|
|
Set Connection = Nothing
|
|
mClose = True
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
|
|
GoTo Exit_Function
|
|
End Function ' (m)Close
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub CloseAllRecordsets()
|
|
' Clean all recordsets for housekeeping
|
|
|
|
Dim sRecordsets() As String, i As Integer, oRecordset As Object
|
|
On Local Error Goto Exit_Sub
|
|
|
|
If IsNull(RecordsetsColl) Then Exit Sub
|
|
If RecordsetsColl.Count < 1 Then Exit Sub
|
|
For i = 1 To RecordsetsColl.Count
|
|
Set oRecordset = RecordsetsColl.Item(i)
|
|
oRecordset.mClose(False) ' Do not remove entry in collection
|
|
Next i
|
|
Set RecordsetsColl = New Collection
|
|
RecordsetMax = 0
|
|
|
|
Exit_Sub:
|
|
Exit Sub
|
|
End Sub ' CloseAllRecordsets V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
|
|
, ByVal Optional pvSql As Variant _
|
|
, ByVal Optional pvOption As Variant _
|
|
) As Object
|
|
'Return a (new) QueryDef object based on SQL statement
|
|
Const cstThisSub = "Database.CreateQueryDef"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Const cstNull = -1
|
|
Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Set CreateQueryDef = Nothing
|
|
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
|
If IsMissing(pvQueryName) Then Call _TraceArguments()
|
|
If IsMissing(pvSql) Then Call _TraceArguments()
|
|
If IsMissing(pvOption) Then pvOption = cstNull
|
|
|
|
If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
|
|
If pvQueryName = "" Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
|
|
If pvSql = "" Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
|
|
|
If _ReadOnly Then Goto Error_NoUpdate
|
|
|
|
Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition")
|
|
oQuery.rename(pvQueryName)
|
|
oQuery.Command = _ReplaceSquareBrackets(pvSql)
|
|
oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
|
|
|
|
Set oQueries = Document.DataSource.getQueryDefinitions()
|
|
With oQueries
|
|
For i = 0 To .getCount() - 1
|
|
sQueryName = .getByIndex(i).Name
|
|
If UCase(sQueryName) = UCase(pvQueryName) Then
|
|
TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
|
|
.removeByName(sQueryName)
|
|
Exit For
|
|
End If
|
|
Next i
|
|
.insertByName(pvQueryName, oQuery)
|
|
End With
|
|
Set CreateQueryDef = QueryDefs(pvQueryName)
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_NoUpdate:
|
|
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' CreateQueryDef V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
|
|
'Return a (new/empty) TableDef object
|
|
Const cstThisSub = "Database.CreateTableDef"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Dim oTable As Object, oTables As Object, sTables() As String
|
|
Dim i As Integer, sTableName As String, oNewTable As Object
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Set CreateTableDef = Nothing
|
|
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
|
If IsMissing(pvTableName) Then Call _TraceArguments()
|
|
|
|
If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
|
|
If pvTableName = "" Then Call _TraceArguments()
|
|
|
|
If _ReadOnly Then Goto Error_NoUpdate
|
|
|
|
Set oTables = Connection.getTables
|
|
With oTables
|
|
sTables = .ElementNames()
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sTables)
|
|
If UCase(pvTableName) = UCase(sTables(i)) Then
|
|
sTableName = sTables(i)
|
|
TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
|
|
.dropByName(sTableName)
|
|
Exit For
|
|
End If
|
|
Next i
|
|
Set oNewTable = New DataDef
|
|
oNewTable._Type = OBJTABLEDEF
|
|
oNewTable._Name = pvTableName
|
|
Set oNewTable._ParentDatabase = _This
|
|
Set oNewTable.TableDescriptor = .createDataDescriptor()
|
|
oNewTable.TableDescriptor.Name = pvTableName
|
|
End With
|
|
|
|
Set CreateTabledef = oNewTable
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_NoUpdate:
|
|
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' CreateTableDef V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DAvg( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return average of scope
|
|
Const cstThisSub = "Database.DAvg"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DAvg
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DCount( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return # of occurrences of scope
|
|
Const cstThisSub = "Database.DCount"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DCount
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DLookup( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
, ByVal Optional pvOrderClause As Variant _
|
|
) As Variant
|
|
|
|
' Return a value within a table
|
|
'Arguments: psExpr: an SQL expression
|
|
' psDomain: a table- or queryname
|
|
' pvCriteria: an optional WHERE clause
|
|
' pcOrderClause: an optional order clause incl. "DESC" if relevant
|
|
'Return: Value of the psExpr if found, else Null.
|
|
'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
|
|
'Examples:
|
|
' 1. To find the last value, include DESC in the OrderClause, e.g.:
|
|
' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
|
|
' 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
|
|
' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
|
|
|
|
Const cstThisSub = "Database.DLookup"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DLookup = _DFunction("", psExpr, psDomain _
|
|
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
|
|
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
|
|
)
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DLookup
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMax( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return maximum of scope
|
|
Const cstThisSub = "Database.DMax"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMax
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMin( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return minimum of scope
|
|
Const cstThisSub = "Database.DMin"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMin
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDev( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "Database.DStDev"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDev
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDevP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "Database.DStDevP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDevP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DSum( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return sum of scope
|
|
Const cstThisSub = "Database.DSum"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DSum
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVar( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "Database.DVar"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVar
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVarP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "Database.DVarP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVarP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
|
' Return property value of psProperty property name
|
|
|
|
Utils._SetCalledSub("Database.getProperty")
|
|
If IsMissing(pvProperty) Then Call _TraceArguments()
|
|
getProperty = _PropertyGet(pvProperty)
|
|
Utils._ResetCalledSub("Database.getProperty")
|
|
|
|
End Function ' getProperty
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
|
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
|
|
|
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
|
Exit Function
|
|
|
|
End Function ' hasProperty
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function OpenRecordset(ByVal Optional pvSource As Variant _
|
|
, ByVal Optional pvType As Variant _
|
|
, ByVal Optional pvOptions As Variant _
|
|
, ByVal Optional pvLockEdit As Variant _
|
|
) As Object
|
|
'Return a Recordset object based on Source (= SQL, table or query name)
|
|
|
|
Const cstThisSub = "Database.OpenRecordset"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
Const cstNull = -1
|
|
|
|
Dim lCommandType As Long, sCommand As String, oObject As Object
|
|
Dim sSource As String, i As Integer, iCount As Integer
|
|
Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Set oObject = Nothing
|
|
If IsMissing(pvSource) Then Call _TraceArguments()
|
|
If pvSource = "" Then Call _TraceArguments()
|
|
If IsMissing(pvType) Then
|
|
pvType = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), dbOpenForwardOnly) Then Goto Exit_Function
|
|
End If
|
|
If IsMissing(pvOptions) Then
|
|
pvOptions = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
|
|
End If
|
|
If IsMissing(pvLockEdit) Then
|
|
pvLockEdit = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), dbReadOnly) Then Goto Exit_Function
|
|
End If
|
|
|
|
sSource = Split(UCase(Trim(pvSource)), " ")(0)
|
|
Select Case True
|
|
Case sSource = "SELECT"
|
|
lCommandType = com.sun.star.sdb.CommandType.COMMAND
|
|
sCommand = _ReplaceSquareBrackets(pvSource)
|
|
Case Else
|
|
sSource = UCase(Trim(pvSource))
|
|
REM Explore tables
|
|
Set oTables = Connection.getTables
|
|
sObjects = oTables.ElementNames()
|
|
bFound = False
|
|
For i = 0 To UBound(sObjects)
|
|
If sSource = UCase(sObjects(i)) Then
|
|
sCommand = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If bFound Then
|
|
lCommandType = com.sun.star.sdb.CommandType.TABLE
|
|
Else
|
|
REM Explore queries
|
|
Set oQueries = Connection.getQueries
|
|
sObjects = oQueries.ElementNames()
|
|
For i = 0 To UBound(sObjects)
|
|
If sSource = UCase(sObjects(i)) Then
|
|
sCommand = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
lCommandType = com.sun.star.sdb.CommandType.QUERY
|
|
End If
|
|
End Select
|
|
|
|
Set oObject = New Recordset
|
|
With oObject
|
|
._CommandType = lCommandType
|
|
._Command = sCommand
|
|
._ParentName = Title
|
|
._ParentType = _Type
|
|
._ForwardOnly = ( pvType = dbOpenForwardOnly )
|
|
._PassThrough = ( pvOptions = dbSQLPassThrough )
|
|
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
|
|
Set ._ParentDatabase = _This
|
|
Call ._Initialize()
|
|
RecordsetMax = RecordsetMax + 1
|
|
._Name = Format(RecordsetMax, "0000000")
|
|
RecordsetsColl.Add(oObject, UCase(._Name))
|
|
End With
|
|
|
|
If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
|
|
|
|
Exit_Function:
|
|
Set OpenRecordset = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource))
|
|
Goto Exit_Function
|
|
End Function ' OpenRecordset V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function OpenSQL(Optional ByVal pvSQL As Variant _
|
|
, Optional ByVal pvOption As Variant _
|
|
) As Boolean
|
|
' Return True if the execution of the SQL statement was successful
|
|
' SQL must contain a SELECT query
|
|
' pvOption can force pass through mode
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Const cstThisSub = "Database.OpenSQL"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
OpenSQL = False
|
|
If IsMissing(pvSQL) Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
|
|
Const cstNull = -1
|
|
If IsMissing(pvOption) Then
|
|
pvOption = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
|
|
End If
|
|
If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable
|
|
|
|
Dim oURL As New com.sun.star.util.URL, oDispatch As Object
|
|
Dim vArgs(8) as New com.sun.star.beans.PropertyValue
|
|
|
|
oURL.Complete = ".component:DB/DataSourceBrowser"
|
|
oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8)
|
|
|
|
vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection
|
|
vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND
|
|
vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL)
|
|
vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True
|
|
vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False
|
|
vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False
|
|
vArgs(6).Name = "Filter" : vArgs(6).Value = ""
|
|
vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False
|
|
vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))
|
|
|
|
oDispatch.dispatch(oURL, vArgs)
|
|
OpenSQL = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "OpenSQL", Erl)
|
|
GoTo Exit_Function
|
|
SQL_Error:
|
|
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
|
|
Goto Exit_Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
End Function ' OpenSQL V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return
|
|
' a Collection object if pvIndex absent
|
|
' a Property object otherwise
|
|
|
|
Utils._SetCalledSub("Database.Properties")
|
|
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
|
vPropertiesList = _PropertiesList()
|
|
sObject = Utils._PCase(_Type)
|
|
If IsMissing(pvIndex) Then
|
|
vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList)
|
|
Else
|
|
vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList, pvIndex)
|
|
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
|
End If
|
|
Set vProperty._ParentDatabase = _This
|
|
|
|
Exit_Function:
|
|
Set Properties = vProperty
|
|
Utils._ResetCalledSub("Database.Properties")
|
|
Exit Function
|
|
End Function ' Properties
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
|
|
' Collect all Queries in the database
|
|
' pbCheck unpublished
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.QueryDefs")
|
|
If IsMissing(pbCheck) Then pbCheck = False
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oQueries As Object
|
|
Set oObject = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Set oQueries = Connection.getQueries
|
|
sObjects = oQueries.ElementNames()
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
oObject._CollType = COLLQUERYDEFS
|
|
oObject._ParentType = OBJDATABASE
|
|
oObject._ParentName = ""
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._Count = UBound(sObjects) + 1
|
|
Goto Exit_Function
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = False
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sObjects)
|
|
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
|
sObjectName = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
|
sObjectName = sObjects(pvIndex)
|
|
End Select
|
|
|
|
Set oObject = New DataDef
|
|
oObject._Type = OBJQUERYDEF
|
|
oObject._Name = sObjectName
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._readOnly = _ReadOnly
|
|
Set oObject.Query = oQueries.getByName(sObjectName)
|
|
|
|
Exit_Function:
|
|
Set QueryDefs = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub("Database.QueryDefs")
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' QueryDefs V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
|
|
' Collect all active recordsets
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.Recordsets")
|
|
|
|
Set Recordsets = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oTables As Object
|
|
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
oObject._CollType = COLLRECORDSETS
|
|
oObject._ParentType = OBJDATABASE
|
|
oObject._ParentName = ""
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._Count = RecordsetsColl.Count
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = _hasRecordset(pvIndex)
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Set oObject = RecordsetsColl.Item(pvIndex)
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError
|
|
Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numbered 1 ... Count
|
|
End Select
|
|
|
|
Exit_Function:
|
|
Set Recordsets = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub("Database.Recordsets")
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database.Recordsets", Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' Recordsets V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function RunSQL(Optional ByVal pvSQL As Variant _
|
|
, Optional ByVal pvOption As Variant _
|
|
) As Boolean
|
|
' Return True if the execution of the SQL statement was successful
|
|
' SQL must contain an ACTION query
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Utils._SetCalledSub("RunSQL")
|
|
|
|
RunSQL = False
|
|
If IsMissing(pvSQL) Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
|
|
Const cstNull = -1
|
|
If IsMissing(pvOption) Then
|
|
pvOption = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Dim oStatement As Object, vResult As Variant
|
|
Set oStatement = Connection.createStatement()
|
|
oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
|
|
On Local Error Goto SQL_Error
|
|
vResult = oStatement.executeUpdate(_ReplaceSquareBrackets(pvSQL))
|
|
On Local Error Goto Error_Function
|
|
RunSQL = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "RunSQL", Erl)
|
|
GoTo Exit_Function
|
|
SQL_Error:
|
|
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
|
|
Goto Exit_Function
|
|
End Function ' RunSQL V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
|
|
' Collect all tables in the database
|
|
' pbCheck unpublished
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.TableDefs")
|
|
If IsMissing(pbCheck) Then pbCheck = False
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oTables As Object
|
|
Set oObject = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Set oTables = Connection.getTables
|
|
sObjects = oTables.ElementNames()
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
oObject._CollType = COLLTABLEDEFS
|
|
oObject._ParentType = OBJDATABASE
|
|
oObject._ParentName = ""
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._Count = UBound(sObjects) + 1
|
|
Goto Exit_Function
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = False
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sObjects)
|
|
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
|
sObjectName = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
|
sObjectName = sObjects(pvIndex)
|
|
End Select
|
|
|
|
Set oObject = New DataDef
|
|
oObject._Type = OBJTABLEDEF
|
|
oObject._Name = sObjectName
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._ReadOnly = _ReadOnly
|
|
Set oObject.Table = oTables.getByName(sObjectName)
|
|
|
|
Exit_Function:
|
|
Set TableDefs = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub("Database.TableDefs")
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database.TableDefs", Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' TableDefs V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- PRIVATE FUNCTIONS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _DFunction(ByVal psFunction As String _
|
|
, ByVal psExpr As String _
|
|
, ByVal psDomain As String _
|
|
, ByVal pvCriteria As Variant _
|
|
, ByVal Optional pvOrderClause As Variant _
|
|
) As Variant
|
|
'Arguments: psFunction an optional aggregate function
|
|
' psExpr: an SQL expression [might contain an aggregate function]
|
|
' psDomain: a table- or queryname
|
|
' pvCriteria: an optional WHERE clause
|
|
' pcOrderClause: an optional order clause incl. "DESC" if relevant
|
|
|
|
If _ErrorHandler() Then On Local Error GoTo Error_Function
|
|
|
|
Dim oResult As Object 'To retrieve the value to find.
|
|
Dim vResult As Variant 'Return value for function.
|
|
Dim sSql As String 'SQL statement.
|
|
Dim oStatement As Object 'For CreateStatement method
|
|
Dim sExpr As String 'For inclusion of aggregate function
|
|
Dim sTempField As String 'Random temporary field in SQL expression
|
|
|
|
vResult = Null
|
|
|
|
If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")"
|
|
|
|
Randomize 2^14-1
|
|
sTempField = "TEMP" & Right("00000" & Int(100000 * Rnd), 5)
|
|
sSql = "SELECT " & sExpr & " AS [" & sTempField & "] FROM " & psDomain
|
|
If pvCriteria <> "" Then
|
|
sSql = sSql & " WHERE " & pvCriteria
|
|
End If
|
|
If pvOrderClause <> "" Then
|
|
sSql = sSql & " ORDER BY " & pvOrderClause
|
|
End If
|
|
|
|
'Lookup the value.
|
|
Set oStatement = Connection.createStatement()
|
|
With oStatement
|
|
.ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
|
|
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
|
|
.EscapeProcessing = False
|
|
sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
|
|
Set oResult = .executeQuery(sSql)
|
|
If Not IsNull(oResult) And Not IsEmpty(oResult) Then
|
|
If Not oResult.next() Then Goto Exit_Function
|
|
vResult = Utils._getResultSetColumnValue(oResult, 1)
|
|
End If
|
|
End With
|
|
|
|
Exit_Function:
|
|
'Assign the returned value.
|
|
_DFunction = vResult
|
|
Set oResult = Nothing
|
|
Set oStatement = Nothing
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
|
|
Goto Exit_Function
|
|
End Function ' DFunction V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _hasRecordset(ByVal psName As String) As Boolean
|
|
' Return True if psName if in the collection of Recordsets
|
|
|
|
Dim oRecordset As Object
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Set oRecordset = RecordsetsColl.Item(psName)
|
|
_hasRecordset = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function: ' Item by key aborted
|
|
_hasRecordset = False
|
|
GoTo Exit_Function
|
|
End Function ' _hasRecordset V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _PropertiesList() As Variant
|
|
|
|
_PropertiesList = Array("ObjectType")
|
|
|
|
End Function ' _PropertiesList
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
|
' Return property value of the psProperty property name
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.get" & psProperty)
|
|
Dim vEMPTY As Variant
|
|
_PropertyGet = vEMPTY
|
|
|
|
Select Case UCase(psProperty)
|
|
Case UCase("ObjectType")
|
|
_PropertyGet = _Type
|
|
Case Else
|
|
Goto Trace_Error
|
|
End Select
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub("Database.get" & psProperty)
|
|
Exit Function
|
|
Trace_Error:
|
|
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
|
_PropertyGet = vEMPTY
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl)
|
|
_PropertyGet = vEMPTY
|
|
GoTo Exit_Function
|
|
End Function ' _PropertyGet
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
|
|
' Returns psSql after substitution of [] by quote character
|
|
' [] square brackets in (single) quoted strings not affected
|
|
|
|
Dim sQuote As String 'RDBMS specific quote character
|
|
Dim vSubStrings() As Variant, i As Integer
|
|
Const cstSingleQuote = "'"
|
|
|
|
sQuote = MetaData.IdentifierQuoteString
|
|
If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported.
|
|
_ReplaceSquareBrackets = Trim(psSql)
|
|
Exit Function
|
|
End If
|
|
vSubStrings() = Split(psSql, cstSingleQuote)
|
|
For i = 0 To UBound(vSubStrings)
|
|
If (i Mod 2) = 0 Then ' Only even substrings are parsed for square brackets
|
|
vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote)
|
|
vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote)
|
|
End If
|
|
Next i
|
|
|
|
_ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote))
|
|
|
|
End Function ' ReplaceSquareBrackets V1.1.0
|
|
</script:module> |