1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
<?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 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
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
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
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 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>
|
