2013-10-12 10:56:41 +02:00
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
2013-10-27 15:05:18 +01:00
<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
2013-10-12 10:56:41 +02:00
Option ClassModule
Option Explicit
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private _Type As String ' Must be DATABASE
2014-05-10 16:01:47 +02:00
Private _This As Object ' Workaround for absence of This builtin function
Private _DbConnect As Integer ' DBCONNECTxxx constants
2013-10-12 10:56:41 +02:00
Private Title As String
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
Private URL As String
2014-05-10 16:01:47 +02:00
Private _ReadOnly As Boolean
2013-10-12 10:56:41 +02:00
Private MetaData As Object ' interface XDatabaseMetaData
Private Form As Object ' com.sun.star.form.XForm
2014-05-10 16:01:47 +02:00
Private FormName As String
2013-10-12 10:56:41 +02:00
Private RecordsetMax As Integer
2013-10-27 15:05:18 +01:00
Private RecordsetsColl As Object ' Collection of active recordsets
2013-10-12 10:56:41 +02:00
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJDATABASE
2014-05-10 16:01:47 +02:00
Set _This = Nothing
_DbConnect = 0
2013-10-12 10:56:41 +02:00
Title = ""
Set Document = Nothing
Set Connection = Nothing
URL = ""
2014-05-10 16:01:47 +02:00
_ReadOnly = False
2013-10-12 10:56:41 +02:00
Set MetaData = Nothing
Set Form = Nothing
FormName = ""
RecordsetMax = 0
Set RecordsetsColl = New Collection
End Sub ' Constructor
REM -----------------------------------------------------------------------------------------------------------------------
'Private Sub Class_Terminate()
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 -----------------------------------------------------------------------------------------------------------------------
2014-05-10 16:01:47 +02:00
REM -----------------------------------------------------------------------------------------------------------------------
Public Function mClose() As Variant
' Close the form
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()
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
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String
2013-10-12 10:56:41 +02:00
If _ErrorHandler() Then On Local Error Goto Error_Function
Set CreateQueryDef = Nothing
2014-05-10 16:01:47 +02:00
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
If _ReadOnly Then Goto Error_NoUpdate
2013-10-12 10:56:41 +02:00
Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition")
oQuery.rename(pvQueryName)
2014-05-10 16:01:47 +02:00
oQuery.Command = _ReplaceSquareBrackets(pvSql)
2013-10-12 10:56:41 +02:00
oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
Set oQueries = Document.DataSource.getQueryDefinitions()
With oQueries
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
.insertByName(pvQueryName, oQuery)
End With
Set CreateQueryDef = QueryDefs(pvQueryName)
Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
2014-05-10 16:01:47 +02:00
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)
2013-10-12 10:56:41 +02:00
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
sCommand = _ReplaceSquareBrackets(pvSource)
2013-10-12 10:56:41 +02:00
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 )
2014-05-10 16:01:47 +02:00
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
Set ._ParentDatabase = _This
2013-10-12 10:56:41 +02:00
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:
2014-05-10 16:01:47 +02:00
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)
2013-10-12 10:56:41 +02:00
Goto Exit_Function
2014-05-10 16:01:47 +02:00
End Function ' OpenSQL V1.1.0
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
Set vProperty._ParentDatabase = _This
2013-10-12 10:56:41 +02:00
Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub("Database.Properties")
Exit Function
End Function ' Properties
REM -----------------------------------------------------------------------------------------------------------------------
2014-05-10 16:01:47 +02:00
Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
2013-10-12 10:56:41 +02:00
' Collect all Queries in the database
2014-05-10 16:01:47 +02:00
' pbCheck unpublished
2013-10-12 10:56:41 +02:00
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.QueryDefs")
2014-05-10 16:01:47 +02:00
If IsMissing(pbCheck) Then pbCheck = False
2013-10-12 10:56:41 +02:00
2014-05-10 16:01:47 +02:00
Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oQueries As Object
Set oObject = Nothing
2013-10-12 10:56:41 +02:00
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 = ""
2014-05-10 16:01:47 +02:00
Set oObject._ParentDatabase = _This
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
Set oObject._ParentDatabase = _This
oObject._readOnly = _ReadOnly
2013-10-12 10:56:41 +02:00
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:
2014-05-10 16:01:47 +02:00
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
2013-10-12 10:56:41 +02:00
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
2014-05-10 16:01:47 +02:00
End Function ' QueryDefs V1.1.0
2013-10-12 10:56:41 +02:00
REM -----------------------------------------------------------------------------------------------------------------------
2014-05-10 16:01:47 +02:00
Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
2013-10-12 10:56:41 +02:00
' 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 = ""
2014-05-10 16:01:47 +02:00
Set oObject._ParentDatabase = _This
2013-10-12 10:56:41 +02:00
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:
2014-05-10 16:01:47 +02:00
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
2013-10-12 10:56:41 +02:00
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Recordsets V0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
' Collect all tables in the database
2014-05-10 16:01:47 +02:00
' pbCheck unpublished
2013-10-12 10:56:41 +02:00
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.TableDefs")
2014-05-10 16:01:47 +02:00
If IsMissing(pbCheck) Then pbCheck = False
2013-10-12 10:56:41 +02:00
2014-05-10 16:01:47 +02:00
Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oTables As Object
Set oObject = Nothing
2013-10-12 10:56:41 +02:00
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 = ""
2014-05-10 16:01:47 +02:00
Set oObject._ParentDatabase = _This
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
Set oObject._ParentDatabase = _This
oObject._ReadOnly = _ReadOnly
2013-10-12 10:56:41 +02:00
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:
2014-05-10 16:01:47 +02:00
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
2013-10-12 10:56:41 +02:00
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
2014-05-10 16:01:47 +02:00
End Function ' TableDefs V1.1.0
2013-10-12 10:56:41 +02:00
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
Exit_Function:
2014-05-10 16:01:47 +02:00
'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
2013-10-12 10:56:41 +02:00
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
2014-05-10 16:01:47 +02:00
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
2013-10-12 10:56:41 +02:00
</script:module>