b0e0059ab9
Introduce _This property in all classes and _Parent property where relevant Accelerate processing of Item method in Collections Enhance introspection
311 lines
No EOL
13 KiB
XML
311 lines
No EOL
13 KiB
XML
<?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> |