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 --- FOR INTERNAL USE ONLY --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private ErrorHandler As Boolean Private MinimalTraceLevel As Integer Private TraceLogs() As Variant Private TraceLogCount As Integer Private TraceLogLast As Integer Private TraceLogMaxEntries As Integer Private LastErrorCode As Integer Private LastErrorLevel As String Private ErrorText As String Private ErrorLongText As String Private CalledSub As String Private DebugPrintShort As Boolean Private Introspection As Object ' com.sun.star.beans.Introspection Private VersionNumber As String ' Actual Access2Base version number Private Locale As String Private ExcludeA2B As Boolean Private TextSearch As Object Private SearchOptions As Variant Private FindRecord As Object Private StatusBar As Object Private Dialogs As Object ' Collection Private TempVars As Object ' Collection Private CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents Private PythonCache() As Variant ' Array of objects created in Python scripts REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() VersionNumber = Access2Base_Version ErrorHandler = True MinimalTraceLevel = 0 TraceLogs() = Array() TraceLogCount = 0 TraceLogLast = 0 TraceLogMaxEntries = 0 LastErrorCode = 0 LastErrorLevel = "" ErrorText = "" ErrorLongText = "" CalledSub = "" DebugPrintShort = True Locale = L10N._GetLocale() ExcludeA2B = True Set Introspection = CreateUnoService("com.sun.star.beans.Introspection") Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch") SearchOptions = New com.sun.star.util.SearchOptions With SearchOptions .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP .searchFlag = 0 .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE End With Set FindRecord = Nothing Set StatusBar = Nothing Set Dialogs = New Collection Set TempVars = New Collection CurrentDoc = Array() ReDim CurrentDoc(0 To 0) Set CurrentDoc(0) = Nothing PythonCache = Array() End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() 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 ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function AddPython(ByRef pvObject As Variant) As Long ' Store the object as a new entry in PythonCache and return its entry number Dim lVars As Long, vObject As Variant lVars = UBound(PythonCache) + 1 ReDim Preserve PythonCache(0 To lVars) PythonCache(lVars) = pvObject AddPython = lVars End Function ' AddPython V6.4 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub CloseConnection() ' Close all connections established by current document to free memory. ' - if Base document => close the one concerned database connection ' - if non-Base documents => close the connections of each individual standalone form Dim i As Integer, iCurrentDoc As Integer Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant If ErrorHandler Then On Local Error Goto Error_Sub If Not IsArray(CurrentDoc) Then Goto Exit_Sub If UBound(CurrentDoc) < 0 Then Goto Exit_Sub iCurrentDoc = CurrentDocIndex( , False) ' False prevents error raising if not found If iCurrentDoc < 0 Then GoTo Exit_Sub ' If not found ignore vDocContainer = CurrentDocument(iCurrentDoc) With vDocContainer If Not .Active Then GoTo Exit_Sub ' e.g. if multiple calls to CloseConnection() For i = 0 To UBound(.DbContainers) If Not IsNull(.DbContainers(i).Database) Then .DbContainers(i).Database.Dispose() Set .DbContainers(i).Database = Nothing End If TraceLog(TRACEANY, UCase(CalledSub) & " " & .URL & Iif(i = 0, "", " Form=" & .DbContainers(i).FormName), False) Set .DbContainers(i) = Nothing Next i .DbContainers = Array() .URL = "" .DbConnect = 0 .Active = False Set .Document = Nothing End With CurrentDoc(iCurrentDoc) = vDocContainer Exit_Sub: Exit Sub Error_Sub: TraceError(TRACEABORT, Err, CalledSub, Erl, False) ' No error message addressed to the user, only stored in console GoTo Exit_Sub End Sub ' CloseConnection REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentDb() As Object ' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties Dim iCurrentDoc As Integer Set CurrentDb = Nothing If Not IsArray(CurrentDoc) Then Goto Exit_Function If UBound(CurrentDoc) < 0 Then Goto Exit_Function iCurrentDoc = CurrentDocIndex(, False) ' False = no abort If iCurrentDoc >= 0 Then If UBound(CurrentDoc(iCurrentDoc).DbContainers) >= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database End If Exit_Function: Exit Function End Function ' CurrentDb REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer ' Returns the entry in CurrentDoc(...) referring to the current document Dim i As Integer, bFound As Boolean, sURL As String Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument" bFound = False CurrentDocIndex = -1 If Not IsArray(CurrentDoc) Then Goto Trace_Error If UBound(CurrentDoc) < 0 Then Goto Trace_Error For i = 1 To UBound(CurrentDoc) ' [0] reserved to database .odb document If IsMissing(pvURL) Then ' Not on 1 single line ?!? If Utils._hasUNOProperty(ThisComponent, "URL") Then sURL = ThisComponent.URL Else Exit For ' f.i. ThisComponent = Basic IDE ... End If Else sURL = pvURL ' To support the SelectObject action End If If CurrentDoc(i).Active And CurrentDoc(i).URL = sURL Then CurrentDocIndex = i bFound = True Exit For End If Next i If Not bFound Then If IsNull(CurrentDoc(0)) Then GoTo Trace_Error With CurrentDoc(0) If Not .Active Then GoTo Trace_Error If IsNull(.Document) Then GoTo Trace_Error End With CurrentDocIndex = 0 End If Exit_Function: Exit Function Trace_Error: If IsMissing(pbAbort) Then pbAbort = True If pbAbort Then TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Else CurrentDocIndex = -1 Goto Exit_Function End Function ' CurrentDocIndex REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant ' Returns the CurrentDoc(...) referring to the current document or to the argument Dim iDocIndex As Integer If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex(, False) Else iDocIndex = piDocIndex If iDocIndex >= 0 And iDocIndex <= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing End Function REM ----------------------------------------------------------------------------------------------------------------------- Public Sub Dump() ' For debugging purposes Dim i As Integer, j As Integer, vCurrentDoc As Variant On Local Error Resume Next DebugPrint "Version", VersionNumber DebugPrint "TraceLevel", MinimalTraceLevel DebugPrint "TraceCount", TraceLogCount DebugPrint "CalledSub", CalledSub If IsArray(CurrentDoc) Then For i = 0 To UBound(CurrentDoc) vCurrentDoc = CurrentDoc(i) If Not IsNull(vCurrentDoc) Then DebugPrint i, "URL", vCurrentDoc.URL For j = 0 To UBound(vCurrentDoc.DbContainers) DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title Next j End If Next i End If End Sub REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasItem(psCollType As String, ByVal psName As String) As Boolean ' Return True if psName if in the collection Dim oItem As Object On Local Error Goto Error_Function ' Whatever ErrorHandler ! hasItem = True Select Case psCollType Case COLLALLDIALOGS Set oItem = Dialogs.Item(UCase(psName)) Case COLLTEMPVARS Set oItem = TempVars.Item(UCase(psName)) Case Else hasItem = False End Select Exit_Function: Exit Function Error_Function: ' Item by key aborted hasItem = False GoTo Exit_Function End Function ' hasItem REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) REM With 2 arguments return the corresponding entry in Root Dim odbDatabase As Variant If IsMissing(piDocEntry) Then Set odbDatabase = CurrentDb() Else If Not IsArray(CurrentDoc) Then Goto Trace_Error If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error If piDocEntry > UBound(CurrentDoc) Then Goto Trace_Error If piDbEntry > UBound(CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error Set odbDatabase = CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database End If If IsNull(odbDatabase) Then GoTo Trace_Error Exit_Function: Set _CurrentDb = odbDatabase Exit Function Trace_Error: TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Goto Exit_Function End Function ' _CurrentDb