Quelle  Root_.xba   Sprache: unbekannt

<?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>