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 _Standalone As Boolean Private Title As String Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper Private URL As String Private MetaData As Object ' interface XDatabaseMetaData Private Form As Object ' com.sun.star.form.XForm Private FormName As String ' name of standalone form Private FindRecord As Object Private StatusBar As Object Private Dialogs As Object ' Collection Private RecordsetMax As Integer Private RecordsetsColl As Object ' Collection of active recordsets REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJDATABASE _Standalone = False Title = "" Set Document = Nothing Set Connection = Nothing URL = "" Set MetaData = Nothing Set Form = Nothing FormName = "" Set FindRecord = Nothing Set StatusBar = Nothing Set Dialogs = New Collection 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 ----------------------------------------------------------------------------------------------------------------------- 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 If _ErrorHandler() Then On Local Error Goto Error_Function Set CreateQueryDef = Nothing If _Standalone() Then Goto Error_Standalone 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 Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition") oQuery.rename(pvQueryName) oQuery.Command = Utils._ReplaceSquareBrackets(pvSql) oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) Set oQueries = Document.DataSource.getQueryDefinitions() With oQueries If .hasByName(pvQueryName) Then TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, pvQueryName) .removeByName(pvQueryName) End If .insertByName(pvQueryName, oQuery) End With Set CreateQueryDef = QueryDefs(pvQueryName) Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Standalone: TraceError(TRACEFATAL, ERRSTANDALONE, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' CreateQueryDef V0.9.5 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 = Trim(Utils._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 ) 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("Table/Query", pvSource)) Goto Exit_Function End Function ' OpenRecordset V0.9.5 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 Exit_Function: Set Properties = vProperty Utils._ResetCalledSub("Database.Properties") Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Public Function QueryDefs(ByVal Optional pvIndex As variant) As Object ' Collect all Queries in the database ' Check when standalone <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Database.QueryDefs") Set QueryDefs = 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, oQueries As Object 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 = "" 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.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: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Query", pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function End Function ' QueryDefs V0.9.5 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 = "" 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("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 TableDefs(ByVal Optional pvIndex As variant) As Object ' Collect all tables in the database ' Check when standalone <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Database.TableDefs") Set TableDefs = 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 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 = "" 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.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: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Table", pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function End Function ' TableDefs V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function _hasDialog(ByVal psName As String) As Boolean ' Return True if psName if in the collection of started dialogs Dim oDialog As Object If _ErrorHandler() Then On Local Error Goto Error_Function Set oDialog = Dialogs.Item(UCase(psName)) _hasDialog = True Exit_Function: Exit Function Error_Function: ' Item by key aborted _hasDialog = False GoTo Exit_Function End Function ' _hasDialog V0.9.1 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