strepsirrhini/office-gobmx
9
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
office-gobmx/wizards/source/access2base/Root_.xba
Jean-Pierre Ledure f55a0a54b2 Access2Base - Internal redesign of root structure into a separate class module 
Redesign of CurrentDb, CurrentDoc interfaces.
Creation of new Root_.xba class module.
Console logs, TempVars and Dialog collections are unchanged.

Change-Id: I573a75e8fb54b277aef84d4518cc8e5cc21d7270
2014-10-17 17:15:41 +02:00

293 lines
No EOL
12 KiB
XML
Raw Blame History

<?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 CalledSub As String
Private Introspection As Object &apos; com.sun.star.beans.Introspection
Private VersionNumber As String &apos; Actual Access2Base version number
Private FindRecord As Object
Private StatusBar As Object
Private Dialogs As Object &apos; Collection
Private TempVars As Object &apos; Collection
Private CurrentDoc() As Variant &apos; Array of document containers - [0] = Base document, [1 ... N] = other documents
Type DocContainer
Document As Object &apos; com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
Active As Boolean
DbConnect As Integer &apos; DBCONNECTxxx constants
URL As String
DbContainers() As Variant &apos; One entry by (data-aware) form
End Type
Type DbContainer
FormName As String &apos; name of data-aware form
Database As Object &apos; Database type
End Type
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
Dim vCurrentDoc() As Variant
VersionNumber = Access2Base_Version
ErrorHandler = True
MinimalTraceLevel = 0
TraceLogs() = Array()
TraceLogCount = 0
TraceLogLast = 0
TraceLogMaxEntries = 0
CalledSub = &quot;&quot;
Introspection = Nothing
Set FindRecord = Nothing
Set StatusBar = Nothing
Set Dialogs = New Collection
Set TempVars = New Collection
vCurrentDoc() = Array()
ReDim vCurrentDoc(0 To 0)
Set vCurrentDoc(0) = Nothing
Set CurrentDoc() = vCurrentDoc()
End Sub &apos; Constructor
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
Call Class_Initialize()
End Sub &apos; Destructor
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub &apos; Explicit destructor
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseConnection()
&apos; Close all connections established by current document to free memory.
&apos; - if Base document =&gt; close the one concerned database connection
&apos; - if non-Base documents =&gt; 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) &lt; 0 Then Goto Exit_Sub
iCurrentDoc = CurrentDocIndex( , False) &apos; False prevents error raising if not found
If iCurrentDoc &lt; 0 Then GoTo Exit_Sub &apos; If not found ignore
vDocContainer = CurrentDocument(iCurrentDoc)
With vDocContainer
If Not .Active Then GoTo Exit_Sub &apos; e.g. if successive 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) &amp; &quot; &quot; &amp; .URL &amp; Iif(i = 0, &quot;&quot;, &quot; Form=&quot; &amp; .DbContainers(i).FormName), False)
Set .DbContainers(i) = Nothing
Next i
.DbContainers = Array()
.URL = &quot;&quot;
.DbConnect = 0
.Active = False
Set .Document = Nothing
End With
CurrentDoc(iCurrentDoc) = vDocContainer
Exit_Sub:
Exit Sub
Error_Sub:
TraceError(TRACEABORT, Err, CalledSub, Erl, False) &apos; No error message addressed to the user, only stored in console
GoTo Exit_Sub
End Sub &apos; CloseConnection
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDb() As Object
&apos; 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) &lt; 0 Then Goto Exit_Function
iCurrentDoc = CurrentDocIndex(, False) &apos; False = no abort
If iCurrentDoc &gt;= 0 Then
If UBound(CurrentDoc(iCurrentDoc).DbContainers) &gt;= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database
End If
Exit_Function:
Exit Function
End Function &apos; CurrentDb
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer
&apos; Returns the entry in CurrentDoc(...) referring to the current document
Dim i As Integer, bFound As Boolean, sURL As String
Const cstBase = &quot;com.sun.star.comp.dba.ODatabaseDocument&quot;
bFound = False
CurrentDocIndex = -1
If Not IsArray(CurrentDoc) Then Goto Trace_Error
If UBound(CurrentDoc) &lt; 0 Then Goto Trace_Error
For i = 1 To UBound(CurrentDoc) &apos; [0] reserved to database .odb document
If IsMissing(pvURL) Then &apos; Not on 1 single line ?!?
If Utils._hasUNOProperty(ThisComponent, &quot;URL&quot;) Then
sURL = ThisComponent.URL
Else
Exit For &apos; f.i. ThisComponent = Basic IDE ...
End If
Else
sURL = pvURL &apos; 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
If Not Utils._hasUNOProperty(ThisComponent, &quot;URL&quot;) Then Goto Trace_Error
If Utils._ImplementationName(ThisComponent) &lt;&gt; cstBase Or .Document.URL &lt;&gt; ThisComponent.URL Then &apos; Give the parent a try
If Not Utils._hasUNOProperty(ThisComponent, &quot;Parent&quot;) Then Goto Trace_Error
If IsNull(ThisComponent.Parent) Then Goto Trace_Error
If Utils._ImplementationName(ThisComponent.Parent) &lt;&gt; cstBase Then Goto Trace_Error
If Not Utils._hasUNOProperty(ThisComponent.Parent, &quot;URL&quot;) Then Goto Trace_Error
If .Document.URL &lt;&gt; ThisComponent.Parent.URL Then Goto Trace_Error
End If
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 &apos; CurrentDocIndex
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant
&apos; Returns the CurrentDoc(...) referring to the current document or to the argument
Dim iDocIndex As Integer
If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex() Else iDocIndex = piDocIndex
If iDocIndex &gt;= 0 And iDocIndex &lt;= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing
End Function
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dump()
&apos; For debugging purposes
Dim i As Integer, j As Integer, vCurrentDoc As Variant
On Local Error Resume Next
DebugPrint &quot;Version&quot;, VersionNumber
DebugPrint &quot;TraceLevel&quot;, MinimalTraceLevel
DebugPrint &quot;TraceCount&quot;, TraceLogCount
DebugPrint &quot;CalledSub&quot;, CalledSub
If IsArray(CurrentDoc) Then
For i = 0 To UBound(CurrentDoc)
vCurrentDoc = CurrentDoc(i)
If Not IsNull(vCurrentDoc) Then
DebugPrint i, &quot;URL&quot;, vCurrentDoc.URL
For j = 0 To UBound(vCurrentDoc.DbContainers)
DebugPrint i, j, &quot;Form&quot;, vCurrentDoc.DbContainers(j).FormName
DebugPrint i, j, &quot;Database&quot;, 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
&apos; Return True if psName if in the collection
Dim oItem As Object
On Local Error Goto Error_Function &apos; 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: &apos; Item by key aborted
hasItem = False
GoTo Exit_Function
End Function &apos; 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 &lt; 0 Or piDbEntry &lt; 0 Then Goto Trace_Error
If piDocEntry &gt; UBound(CurrentDoc) Then Goto Trace_Error
If piDbEntry &gt; 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 &apos; _CurrentDb
</script:module>
Reference in a new issue View git blame Copy permalink