diff options
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/Root_.xba | 311 |
1 files changed, 311 insertions, 0 deletions
diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba new file mode 100644 index 000000000..73f743278 --- /dev/null +++ b/wizards/source/access2base/Root_.xba @@ -0,0 +1,311 @@ +<?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="Root_" 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 --- 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 + +</script:module>
\ No newline at end of file |