| blob | 74bb43558928a4b42d5c85cf9ae65c9aea442917 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Application" script:language="StarBasic">
4 REM =======================================================================================================================
5 REM === The Access2Base library is a part of the LibreOffice project. ===
6 REM === Full documentation is available on http://www.access2base.com ===
7 REM =======================================================================================================================
9 Option Explicit
11 REM -----------------------------------------------------------------------------------------------------------------------
16 Global Const TRACEFATAL = "FATAL" ' To report programmer errors - f.i. Wrong argument
19 ' ERRORs, FATALs and ABORTs are also displayed in a MsgBox (except on specific request)
20 ' FATALs and ABORTs interrupt the program execution
22 Global Const ERRINIT = 1500
23 Global Const ERRDBNOTCONNECTED = 1501
24 Global Const ERRMISSINGARGUMENTS = 1502
25 Global Const ERRWRONGARGUMENT = 1503
26 Global Const ERRMAINFORM = 1504
27 Global Const ERRMETHOD = 1505
28 Global Const ERRFILEACCESS = 1506
29 Global Const ERRFORMNOTIDENTIFIED = 1507
30 Global Const ERRFORMNOTFOUND = 1508
31 Global Const ERRFORMNOTOPEN = 1509
32 Global Const ERRDFUNCTION = 1510
33 Global Const ERROPENFORM = 1511
34 Global Const ERRPROPERTY = 1512
35 Global Const ERRPROPERTYVALUE = 1513
36 Global Const ERRINDEXVALUE = 1514
37 Global Const ERRCOLLECTION = 1515
38 Global Const ERRPROPERTYNOTARRAY = 1516
39 Global Const ERRCONTROLNOTFOUND = 1517
40 Global Const ERRNOACTIVEFORM = 1518
41 Global Const ERRDATABASEFORM = 1519
42 Global Const ERRFOCUSINGRID = 1520
43 Global Const ERRNOGRIDINFORM = 1521
44 Global Const ERRFINDRECORD = 1522
45 Global Const ERRSQLSTATEMENT = 1523
46 Global Const ERROBJECTNOTFOUND = 1524
47 Global Const ERROPENOBJECT = 1525
48 Global Const ERRCLOSEOBJECT = 1526
49 Global Const ERRMETHOD = 1527
50 Global Const ERRACTION = 1528
51 Global Const ERRSENDMAIL = 1529
52 Global Const ERRFORMYETOPEN = 1530
53 Global Const ERRPROPERTYINIT = 1531
54 Global Const ERRFILENOTCREATED = 1532
55 Global Const ERRDIALOGNOTFOUND = 1533
56 Global Const ERRDIALOGUNDEFINED = 1534
57 Global Const ERRDIALOGSTARTED = 1535
58 Global Const ERRDIALOGNOTSTARTED = 1536
59 Global Const ERRRECORDSETNODATA = 1537
60 Global Const ERRRECORDSETCLOSED = 1538
61 Global Const ERRRECORDSETRANGE = 1539
62 Global Const ERRRECORDSETFORWARD = 1540
63 Global Const ERRFIELDNULL = 1541
64 Global Const ERROVERFLOW = 1542
65 Global Const ERRNOTACTIONQUERY = 1543
66 Global Const ERRNOTUPDATABLE = 1544
67 Global Const ERRUPDATESEQUENCE = 1545
68 Global Const ERRNOTNULLABLE = 1546
69 Global Const ERRROWDELETED = 1547
70 Global Const ERRRECORDSETCLONE = 1548
71 Global Const ERRQUERYDEFDELETED = 1549
72 Global Const ERRTABLEDEFDELETED = 1550
73 Global Const ERRTABLECREATION = 1551
74 Global Const ERRFIELDCREATION = 1552
75 Global Const ERRSUBFORMNOTFOUND = 1553
76 Global Const ERRWINDOW = 1554
77 Global Const ERRCOMPATIBILITY = 1555
78 Global Const ERRPRECISION = 1556
79 Global Const ERRMODULENOTFOUND = 1557
80 Global Const ERRPROCEDURENOTFOUND = 1558
82 REM -----------------------------------------------------------------------------------------------------------------------
85 Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase)
87 REM -----------------------------------------------------------------------------------------------------------------------
88 Global Const DBMS_UNKNOWN = 0
89 Global Const DBMS_HSQLDB1 = 1
90 Global Const DBMS_HSQLDB2 = 2
91 Global Const DBMS_FIREBIRD = 3
92 Global Const DBMS_MSACCESS2003 = 4
93 Global Const DBMS_MSACCESS2007 = 5
94 Global Const DBMS_MYSQL = 6
95 Global Const DBMS_POSTGRES = 7
96 Global Const DBMS_SQLITE = 8
98 REM -----------------------------------------------------------------------------------------------------------------------
113 REM -----------------------------------------------------------------------------------------------------------------------
133 REM -----------------------------------------------------------------------------------------------------------------------
156 REM -----------------------------------------------------------------------------------------------------------------------
161 REM -----------------------------------------------------------------------------------------------------------------------
168 REM -----------------------------------------------------------------------------------------------------------------------
172 REM -----------------------------------------------------------------------------------------------------------------------
173 Type DocContainer
174 Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
175 Active As Boolean
176 DbConnect As Integer ' DBCONNECTxxx constants
177 URL As String
178 DbContainers() As Variant ' One entry by (data-aware) form
179 End Type
181 Type DbContainer
182 FormName As String ' name of data-aware form
183 Database As Object ' Database type
184 End Type
186 REM -----------------------------------------------------------------------------------------------------------------------
187 REM --- Next variable is initialized to empty at each macro execution start ---
188 REM --- Items in both lists correspond one by one ---
189 Public vFormNamesList As Variant ' (0) Buffer of hierarchical form names => "\;" separated values
192 REM -----------------------------------------------------------------------------------------------------------------------
193 Public Function AllDialogs(ByVal Optional pvIndex As Variant) As Variant
194 ' Return either a Collection or a Dialog object
195 ' The dialogs are selected only if library is loaded
197 If _ErrorHandler() Then On Local Error Goto Error_Function
199 Utils._SetCalledSub(cstThisSub)
201 Dim iMode As Integer, vDialogs() As Variant, i As Integer, j As Integer, iCount As Integer
202 Dim oMacLibraries As Object, vAllDialogs As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
203 Dim oLibDialog As Object, sLibrary As String, oDocLibraries As Object, bLocalStorage As Boolean
204 Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
205 Dim vCurrentDocument As Variant
206 Const cstCount = 0
207 Const cstByIndex = 1
208 Const cstByName = 2
211 If IsMissing(pvIndex) Then
212 iMode = cstCount
213 Else
214 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
215 If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
216 End If
218 Set vAllDialogs = Nothing
220 Set vCurrentDocument = Nothing
221 If Not IsNull(_A2B_.CurrentDocument) Then
222 Set vCurrentDocument = _A2B_.CurrentDocument.Document
223 ElseIf Not IsNull(ThisComponent) Then
224 Set vCurrentDocument = ThisComponent
225 End If
226 If IsNull(vCurrentDocument) Then
227 Set oDocLibraries = Nothing
228 vDocLibraries = Array()
229 Else
230 Set oDocLibraries = vCurrentDocument.DialogLibraries
231 vDocLibraries = oDocLibraries.getElementNames()
232 End If
233 Set oMacLibraries = GlobalScope.DialogLibraries
234 vMacLibraries = oMacLibraries.getElementNames()
235 'Remove Access2Base from the list
236 If _A2B_.ExcludeA2B Then
237 For i = 0 To UBound(vMacLibraries)
239 Next i
240 End If
241 vMacLibraries = Utils._TrimArray(vMacLibraries)
244 Set vAllDialogs = New Collect
245 Set vAllDialogs._This = vAllDialogs
246 vAllDialogs._CollType = COLLALLDIALOGS
247 vAllDialogs._Count = 0
248 Goto Exit_Function
249 End If
251 vNames = Array()
252 iCount = 0
254 bFound = False
255 If i <= UBound(vDocLibraries) Then
256 sLibrary = vDocLibraries(i)
257 bLocalStorage = True
258 Set oDocMacLib = oDocLibraries
259 ' Sometimes library not loaded as should ??
260 If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
261 Else
262 sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
263 bLocalStorage = False
264 Set oDocMacLib = oMacLibraries
265 End If
266 If oDocMacLib.IsLibraryLoaded(sLibrary) Then
267 Set oLibrary = oDocMacLib.getByName(sLibrary)
268 If oLibrary.hasElements() Then
269 vDialogs = oLibrary.getElementNames()
270 Select Case iMode
271 Case cstCount
272 iCount = iCount + UBound(vDialogs) + 1
273 Case cstByIndex, cstByName
274 For j = 0 To UBound(vDialogs)
275 If iMode = cstByIndex Then
276 If pvIndex = iCount Then bFound = True
277 iCount = iCount + 1
278 Else
279 If UCase(pvIndex) = UCase(vDialogs(j)) Then bFound = True
280 End If
281 If bFound Then
282 Set oLibDialog = oLibrary.getByName(vDialogs(j)) ' Create Dialog object
283 Exit For
284 End If
285 Next j
286 End Select
287 End If
288 End If
289 If bFound Then Exit For
290 Next i
292 If iMode = cstCount Then
293 Set vAllDialogs = New Collect
294 Set vAllDialogs._This = vAllDialogs
295 vAllDialogs._CollType = COLLALLDIALOGS
296 vAllDialogs._Count = iCount
297 Else
298 If Not bFound Then
299 If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found
300 End If
301 Set vAllDialogs = New Dialog
302 With vAllDialogs
303 ._This = vAllDialogs
304 ._Name = vDialogs(j)
306 Set ._Dialog = oLibDialog
307 ._Library = sLibrary
309 End With
310 End If
312 Exit_Function:
313 Set AllDialogs = vAllDialogs
314 Utils._ResetCalledSub(cstThisSub)
315 Exit Function
316 Trace_Not_Found:
317 TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
318 Goto Exit_Function
319 Trace_Error_Index:
321 Set vDialogs = Nothing
322 Goto Exit_Function
323 Error_Function:
324 TraceError(TRACEABORT, Err, cstThisSub, Erl)
325 Set vDialogs = Nothing
326 GoTo Exit_Function
329 REM -----------------------------------------------------------------------------------------------------------------------
330 Public Function AllForms(ByVal Optional pvIndex As Variant) As Variant
331 ' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string)
333 ' If no argument, return a Collection type
336 Dim iIndex As Integer, vReturn As Variant
337 Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
338 Dim ofForm As Object
339 Dim vAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean
342 If _ErrorHandler() Then On Local Error Goto Error_Function
343 Utils._SetCalledSub(cstThisSub)
344 Set vReturn = Nothing
346 If Not IsMissing(pvIndex) Then
347 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
348 Select Case VarType(pvIndex)
349 Case vbString
350 iIndex = -1
351 Case Else
352 iIndex = pvIndex
353 End Select
354 End If
356 iCurrentDoc = _A2B_.CurrentDocIndex()
358 vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc)
359 Else
360 Goto Exit_Function
361 End If
363 ' Load complete list of hierarchical and persistent names when Base document
364 If vCurrentDoc.DbConnect = DBCONNECTBASE Then vAllForms = _GetAllHierarchicalNames()
366 ' Process when NO ARGUMENT
367 If IsMissing(pvIndex) Then ' No argument
368 Set oCounter = New Collect
369 Set oCounter._This = oCounter
370 oCounter._CollType = COLLALLFORMS
371 If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = UBound(vAllForms) + 1
372 Set vReturn = oCounter
373 Goto Exit_Function
374 End If
377 Set ofForm = New Form
378 Set ofForm._This = ofForm
379 Select Case vCurrentDoc.DbConnect
380 Case DBCONNECTBASE
381 ofForm._DocEntry = 0
382 ofForm._DbEntry = 0
384 vName = Utils._InList(Utils._Trim(pvIndex), vAllForms, True)
385 If vName = False Then Goto Trace_Not_Found
386 ofForm._Initialize(vName)
387 Else
388 If iIndex > UBound(vAllForms) Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense
389 ofForm._Initialize(vAllForms(iIndex))
390 End If
391 Case DBCONNECTFORM
392 With vCurrentDoc
393 If iIndex = -1 Then
394 bFound = False
395 For i = 0 To UBound(vCurrentDoc.DbContainers)
396 Set oDatabase = vCurrentDoc.DbContainers(i).Database
397 If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then
398 bFound = True
399 ofForm._DbEntry = i
400 Exit For
401 End If
402 Next i
403 If Not bFound Then Goto Trace_Not_Found
405 Goto Trace_Error_Index
406 Else
407 ofForm._DbEntry = iIndex
408 Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database
409 End If
410 End With
411 vName = oDatabase.FormName
412 ofForm._DocEntry = iCurrentDoc
413 ofForm._Initialize(vName)
414 End Select
416 Set vReturn = ofForm
418 Exit_Function:
419 Set AllForms = vReturn
420 Utils._ResetCalledSub(cstThisSub)
421 Exit Function
422 Trace_Not_Found:
423 TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
424 Goto Exit_Function
425 Trace_Error_Index:
427 Set vReturn = Nothing
428 Goto Exit_Function
429 Error_Function:
430 TraceError(TRACEABORT, Err, cstThisSub, Erl)
431 Set vReturn = Nothing
432 GoTo Exit_Function
435 REM -----------------------------------------------------------------------------------------------------------------------
436 Public Function AllModules(ByVal Optional pvIndex As Variant, ByVal Optional pbAllModules As Boolean) As Variant
437 ' Return either a Collection or a Module object
438 ' The modules are selected only if library is loaded
439 ' (UNPUBLISHED) pbAllModules = False collects only the modules located in the currently open document
441 If _ErrorHandler() Then On Local Error Goto Error_Function
443 Utils._SetCalledSub(cstThisSub)
445 Dim iMode As Integer, vModules() As Variant, i As Integer, j As Integer, iCount As Integer
446 Dim oMacLibraries As Object, vAllModules As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
447 Dim sScript As String, sLibrary As String, oDocLibraries As Object, sStorage As String
448 Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
452 If IsMissing(pvIndex) Then
453 iMode = cstCount
454 Else
455 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
456 If VarType(pvIndex) = vbString Then
457 iMode = cstByName
458 ' Determine full name STORAGE.LIBRARY.MODULE
459 vNames = Split(pvIndex, cstDot)
460 If UBound(vNames) = 2 Then
461 ElseIf UBound(vNames) = 1 Then
463 ElseIf UBound(vNames) = 0 Then
465 Else
466 GoTo Trace_Not_Found
467 End If
468 Else
469 iMode = cstByIndex
470 End If
471 End If
473 If IsMissing(pbAllModules) Then pbAllModules = True
474 If Not Utils._CheckArgument(pbAllModules, 2, vbBoolean) Then Goto Exit_Function
476 Set vAllModules = Nothing
478 Set oDocLibraries = _A2B_.CurrentDocument.Document.BasicLibraries ' ThisComponent.BasicLibraries
479 vDocLibraries = oDocLibraries.getElementNames()
480 If pbAllModules Then
481 Set oMacLibraries = GlobalScope.BasicLibraries
482 vMacLibraries = oMacLibraries.getElementNames()
483 'Remove Access2Base from the list
484 If _A2B_.ExcludeA2B Then
485 For i = 0 To UBound(vMacLibraries)
487 Next i
488 End If
489 vMacLibraries = Utils._TrimArray(vMacLibraries)
490 End If
493 Set vAllModules = New Collect
494 Set vAllModules._This = vAllModules
495 vAllModules._CollType = COLLALLMODULES
496 vAllModules._Count = 0
497 Goto Exit_Function
498 End If
500 iCount = 0
502 bFound = False
503 If i <= UBound(vDocLibraries) Then
504 sLibrary = vDocLibraries(i)
505 sStorage = MODDOCUMENT
506 Set oDocMacLib = oDocLibraries
507 ' Sometimes library not loaded as should ??
508 If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
509 Else
510 sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
511 sStorage = MODGLOBAL
512 Set oDocMacLib = oMacLibraries
513 End If
514 If oDocMacLib.IsLibraryLoaded(sLibrary) Then
515 Set oLibrary = oDocMacLib.getByName(sLibrary)
516 If oLibrary.hasElements() Then
517 vModules = oLibrary.getElementNames()
518 Select Case iMode
519 Case cstCount
520 iCount = iCount + UBound(vModules) + 1
521 Case cstByIndex, cstByName
522 For j = 0 To UBound(vModules)
523 If iMode = cstByIndex Then
524 If pvIndex = iCount Then bFound = True
525 iCount = iCount + 1
526 Else
527 If UCase(pvIndex) = UCase(sStorage & cstDot & sLibrary & cstDot & vModules(j)) Then bFound = True
528 End If
529 If bFound Then
530 sScript = oLibrary.getByName(vModules(j)) ' Initiate Module object
531 iCount = i
532 Exit For
533 End If
534 Next j
535 End Select
536 End If
537 End If
538 If bFound Then Exit For
539 Next i
541 If iMode = cstCount Then
542 Set vAllModules = New Collect
543 Set vAllModules._This =vAllModules
544 vAllModules._CollType = COLLALLMODULES
545 vAllModules._Count = iCount
546 Else
547 If Not bFound Then
548 If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found
549 End If
550 Set vAllModules = New Module
551 Set vAllModules._This = vAllModules
552 vAllModules._Name = vModules(j)
553 vAllModules._LibraryName = sLibrary
554 Set vAllModules._Library = oLibrary
555 vAllModules._Storage = sStorage
556 vAllModules._Script = sScript
557 vAllModules._Initialize()
558 End If
560 Exit_Function:
561 Set AllModules = vAllModules
562 Utils._ResetCalledSub(cstThisSub)
563 Exit Function
564 Trace_Not_Found:
565 TraceError(TRACEFATAL, ERRMODULENOTFOUND, Utils._CalledSub(), 0, , pvIndex)
566 Goto Exit_Function
567 Trace_Error_Index:
569 Set vModules = Nothing
570 Goto Exit_Function
571 Error_Function:
572 TraceError(TRACEABORT, Err, cstThisSub, Erl)
573 Set vModules = Nothing
574 GoTo Exit_Function
577 REM -----------------------------------------------------------------------------------------------------------------------
578 Public Sub CloseConnection ()
580 ' Close all connections established by current document to free memory.
584 If IsEmpty(_A2B_) Then Goto Exit_Sub
587 Utils._SetCalledSub(cstThisSub)
589 Call _A2B_.CloseConnection()
591 Exit_Sub:
592 Utils._ResetCalledSub(cstThisSub)
593 Exit Sub
596 REM -----------------------------------------------------------------------------------------------------------------------
597 Public Function CommandBars(Optional ByVal pvIndex As Variant, Optional ByRef poWindow As Object) As Variant
598 ' Return an object of type CommandBar indicated by its index or its name (CASE-INSENSITIVE string)
599 ' If no pvIndex argument, return a Collection type
600 ' (Unpublished) With poWindow, force the frame in which toolbars are detected
602 If _ErrorHandler() Then On Local Error Goto Error_Function
604 Utils._SetCalledSub(cstThisSub)
606 Dim iObjectsCount As Integer, sObjectName As String, oObject As Object
607 Dim oWindow As Object, iWindowType As Integer
608 Dim i As Integer, j As Integer, k As Integer, bFound As Boolean
609 Dim sSupportedModules() As Variant, vModules() As Variant, oModuleUI As Object
610 Dim oToolbar As Object, sToolbarName As String, vUIElements() As Variant, sToolbarFullName As String, iBuiltin As Integer
614 Set oObject = Nothing
615 If Not IsMissing(pvIndex) Then
616 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
617 End If
619 iObjectsCount = 0
620 bFound = False
622 If IsMissing(poWindow) Then Set oWindow = _SelectWindow() Else Set oWindow = poWindow
623 If IsNull(oWindow.Frame) Then Goto Trace_WindowError
628 iWindowType = oWindow.WindowType
629 Select Case iWindowType ' Supported window types only
630 Case acForm
632 Case acBasicIDE
634 Case acDatabaseWindow
636 Case acReport
638 Case acDocument
639 Select Case oWindow.DocumentType
642 Case docImpress : sSupportedModules = Array( "com.sun.star.presentation.PresentationDocument" )
645 Case Else : sSupportedModules = Array()
646 End Select
647 Case acTable, acQuery
650 )
651 Case acDiagram
653 Case acWelcome
655 Case Else
656 sSupportedModules = Array()
657 End Select
659 ' Find all standard and custom toolbars stored in LibO/AOO Base
660 Set oModuleUI = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier")
661 For k = 0 To UBound(vModules)
662 For j = 0 To UBound(sSupportedModules)
664 If vModules(k) = sSupportedModules(j) Then ' Supported modules only
665 Set oToolbar = oModuleUI.getUIConfigurationManager(vModules(k))
666 vUIElements() = oToolbar.getUIElementsInfo(0)
667 For i = 0 To UBound(vUIElements)
670 If _IsLeft(UCase(sToolbarName), UCase(cstCustom)) Then
672 iBuiltin = 2
673 End If
675 iObjectsCount = iObjectsCount + 1
676 Select Case True
677 Case IsMissing(pvIndex)
678 Case VarType(pvIndex) = vbString
679 If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True
680 Case Else
682 If pvIndex = iObjectsCount - 1 Then bFound = True
683 End Select
685 If bFound Then
686 Set oObject = _NewCommandBar(vModules(k), sToolbarName, sToolbarFullName, iBuiltin)
687 Set oObject._Window = oWindow.Frame
688 Set oObject._Toolbar = oToolbar
689 Goto Exit_Function
690 End If
691 Next i
692 End If
693 Next j
694 Next k
696 ' Find all (not builtin) toolbars stored in current document (typically forms)
698 Set oToolbar = oWindow.Frame.Controller.Model.getUIConfigurationManager
699 vUIElements() = oToolbar.getUIElementsInfo(0)
700 For i = 0 To UBound(vUIElements)
703 iObjectsCount = iObjectsCount + 1
704 Select Case True
705 Case IsMissing(pvIndex)
706 Case VarType(pvIndex) = vbString
707 If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True
708 Case Else
709 If pvIndex = iObjectsCount - 1 Then bFound = True
710 End Select
711 If bFound Then
712 Set oObject = _NewCommandBar("", sToolbarName, sToolbarFullName, iBuiltin)
713 Set oObject._Window = oWindow.Frame
714 Set oObject._Toolbar = oToolbar
715 Goto Exit_Function
716 End If
717 Next i
719 ' MISSING : CUSTOM POPUPS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
721 Select Case True
722 Case IsMissing(pvIndex)
723 Set oObject = New Collect
724 Set oObject._This = oObject
725 oObject._CollType = COLLCOMMANDBARS
726 oObject._Count = iObjectsCount
727 Case VarType(pvIndex) = vbString
728 Goto Trace_NotFound
729 Case Else ' pvIndex is numeric
730 Goto Trace_IndexError
731 End Select
733 Exit_Function:
734 Set CommandBars = oObject
735 Set oObject = Nothing
736 Utils._ResetCalledSub(cstThisSub)
737 Exit Function
738 Error_Function:
739 TraceError(TRACEABORT, Err, cstThisSub, Erl)
740 GoTo Exit_Function
741 Trace_NotFound:
742 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("COMMANDBAR"), pvIndex))
743 Goto Exit_Function
744 Trace_IndexError:
745 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
746 Goto Exit_Function
747 Trace_WindowError:
748 TraceError(TRACEFATAL, ERRWINDOW, Utils._CalledSub(), 0)
749 Goto Exit_Function
752 REM -----------------------------------------------------------------------------------------------------------------------
753 Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIndex As Variant) As Variant
754 ' Return an object of type Control indicated by either its index (integer) or its name (CASE-INSENSITIVE string)
757 ' a main form name as string
759 ' The Form property in the returned variant contains a SUBFORM type
762 ' If no pvIndex argument, return a Collection type
764 If _ErrorHandler() Then On Local Error Goto Error_Function
765 Dim vObject As Object
767 Utils._SetCalledSub(cstThisSub)
769 If IsMissing(pvObject) Then Call _TraceArguments()
770 If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
771 Controls = EMPTY
773 If VarType(pvObject) = vbString Then
774 Set vObject = Forms(pvObject)
775 If IsNull(vObject) Then Goto Exit_Function
776 Else
777 If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM, OBJOPTIONGROUP, CTLGRIDCONTROL)) Then Goto Exit_Function
778 Set vObject = pvObject
779 End If
781 If IsMissing(pvIndex) Then
782 Controls = vObject.Controls()
783 Else
784 If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function
785 Controls = vObject.Controls(pvIndex)
786 End If
788 Exit_Function:
789 Utils._ResetCalledSub(cstThisSub)
790 Exit Function
791 Error_Function:
792 TraceError(TRACEERROR, Err, cstThisSub, Erl)
793 GoTo Exit_Function
796 REM -----------------------------------------------------------------------------------------------------------------------
797 Public Function CurrentDb() As Object
798 ' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties
801 Utils._SetCalledSub(cstThisSub)
803 Set CurrentDb = Nothing
804 If IsEmpty(_A2B_) Then GoTo Exit_Function
805 Set CurrentDb = _A2B_.CurrentDb()
807 Exit_Function:
808 Utils._ResetCalledSub(cstThisSub)
809 Exit Function
812 REM -----------------------------------------------------------------------------------------------------------------------
813 Public Function CurrentUser() As String
815 Dim oPath As Object, sUser As String
818 sUser = oPath.getSubstituteVariableValue("$(username)") ' New since LibreOffice 5.2
819 CurrentUser = sUser
823 REM -----------------------------------------------------------------------------------------------------------------------
824 Public Function DAvg( _
825 ByVal Optional psExpr As String _
826 , ByVal Optional psDomain As String _
827 , ByVal Optional pvCriteria As Variant _
828 ) As Variant
829 ' Return average of scope
831 Utils._SetCalledSub(cstThisSub)
832 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
833 DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
834 Utils._ResetCalledSub(cstThisSub)
835 End Function ' DAvg
837 REM -----------------------------------------------------------------------------------------------------------------------
838 Public Function DCount( _
839 ByVal Optional psExpr As String _
840 , ByVal Optional psDomain As String _
841 , ByVal Optional pvCriteria As Variant _
842 ) As Variant
843 ' Return # of occurrences of scope
845 Utils._SetCalledSub(cstThisSub)
846 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
847 DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
848 Utils._ResetCalledSub(cstThisSub)
849 End Function ' DCount
851 REM -----------------------------------------------------------------------------------------------------------------------
852 Public Function DLookup( _
853 ByVal Optional psExpr As String _
854 , ByVal Optional psDomain As String _
855 , ByVal Optional pvCriteria As Variant _
856 , ByVal Optional pvOrderClause As Variant _
857 ) As Variant
859 ' Return a value within a table
860 'Arguments: psExpr: an SQL expression
861 ' psDomain: a table- or queryname
862 ' pvCriteria: an optional WHERE clause
864 'Return: Value of the psExpr if found, else Null.
866 'Examples:
868 ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
870 ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
873 Utils._SetCalledSub(cstThisSub)
874 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
875 DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _
876 , Iif(IsMissing(pvCriteria), "", pvCriteria) _
877 , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
878 )
879 Utils._ResetCalledSub(cstThisSub)
880 End Function ' DLookup
882 REM -----------------------------------------------------------------------------------------------------------------------
883 Public Function DMax( _
884 ByVal Optional psExpr As String _
885 , ByVal Optional psDomain As String _
886 , ByVal Optional pvCriteria As Variant _
887 ) As Variant
888 ' Return maximum of scope
890 Utils._SetCalledSub(cstThisSub)
891 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
892 DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
893 Utils._ResetCalledSub(cstThisSub)
894 End Function ' DMax
896 REM -----------------------------------------------------------------------------------------------------------------------
897 Public Function DMin( _
898 ByVal Optional psExpr As String _
899 , ByVal Optional psDomain As String _
900 , ByVal Optional pvCriteria As Variant _
901 ) As Variant
902 ' Return minimum of scope
904 Utils._SetCalledSub(cstThisSub)
905 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
906 DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
907 Utils._ResetCalledSub(cstThisSub)
908 End Function ' DMin
910 REM -----------------------------------------------------------------------------------------------------------------------
911 Public Function DStDev( _
912 ByVal Optional psExpr As String _
913 , ByVal Optional psDomain As String _
914 , ByVal Optional pvCriteria As Variant _
915 ) As Variant
916 ' Return standard deviation of scope
918 Utils._SetCalledSub(cstThisSub)
919 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
920 DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
921 Utils._ResetCalledSub(cstThisSub)
922 End Function ' DStDev
924 REM -----------------------------------------------------------------------------------------------------------------------
925 Public Function DStDevP( _
926 ByVal Optional psExpr As String _
927 , ByVal Optional psDomain As String _
928 , ByVal Optional pvCriteria As Variant _
929 ) As Variant
930 ' Return standard deviation of scope
932 Utils._SetCalledSub(cstThisSub)
933 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
934 DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
935 Utils._ResetCalledSub(cstThisSub)
936 End Function ' DStDevP
938 REM -----------------------------------------------------------------------------------------------------------------------
939 Public Function DSum( _
940 ByVal Optional psExpr As String _
941 , ByVal Optional psDomain As String _
942 , ByVal Optional pvCriteria As Variant _
943 ) As Variant
944 ' Return sum of scope
946 Utils._SetCalledSub(cstThisSub)
947 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
948 DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
949 Utils._ResetCalledSub(cstThisSub)
950 End Function ' DSum
952 REM -----------------------------------------------------------------------------------------------------------------------
953 Public Function DVar( _
954 ByVal Optional psExpr As String _
955 , ByVal Optional psDomain As String _
956 , ByVal Optional pvCriteria As Variant _
957 ) As Variant
958 ' Return variance of scope
960 Utils._SetCalledSub(cstThisSub)
961 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
962 DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
963 Utils._ResetCalledSub(cstThisSub)
964 End Function ' DVar
966 REM -----------------------------------------------------------------------------------------------------------------------
967 Public Function DVarP( _
968 ByVal Optional psExpr As String _
969 , ByVal Optional psDomain As String _
970 , ByVal Optional pvCriteria As Variant _
971 ) As Variant
972 ' Return variance of scope
974 Utils._SetCalledSub(cstThisSub)
975 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
976 DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
977 Utils._ResetCalledSub(cstThisSub)
978 End Function ' DVarP
980 REM -----------------------------------------------------------------------------------------------------------------------
981 Public Function Events(Optional poEvent As Variant) As Variant
982 ' Return an event object corresponding with actual event
984 Dim vEvent As Variant
985 If _ErrorHandler() Then On Local Error Goto Error_Function
987 Utils._SetCalledSub(cstThisSub)
989 Set vEvent = Nothing
990 If IsMissing(poEvent) Then Goto Exit_Function
991 If IsNull(poEvent) Then Goto Exit_Function
993 If Not Utils._CheckArgument(poEvent, 1, vbObject, , False) Then Goto Exit_Function ' No error handling in CheckArgument
995 Set vEvent = New Event
996 vEvent._Initialize(poEvent)
998 Exit_Function:
999 Set Events = vEvent
1000 Utils._ResetCalledSub(cstThisSub)
1001 Exit Function
1002 Error_Function:
1003 TraceError(TRACEWARNING, Err, cstThisSub, Erl)
1004 GoTo Exit_Function
1005 Trace_Error:
1006 ' Errors are not displayed to avoid display infinite cycling
1007 TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent)))
1008 Set vEvent = Nothing
1009 Goto Exit_Function
1012 REM -----------------------------------------------------------------------------------------------------------------------
1013 Public Function Forms(ByVal Optional pvIndex As Variant) As Variant
1014 ' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string)
1015 ' The concerned form must be loaded.
1016 ' If no argument, return a Collection type
1019 Utils._SetCalledSub(cstThisSub)
1020 If _ErrorHandler() Then On Local Error Goto Error_Function
1022 Dim ofForm As Object, oCounter As Variant, vForms As Variant, oIndex As Object
1023 Set vForms = Nothing
1025 Dim iCount As Integer
1026 If IsMissing(pvIndex) Then
1027 iCount = Application._CountOpenForms()
1028 Set oCounter = New Collect
1029 Set oCounter._This = oCounter
1030 oCounter._CollType = COLLFORMS
1031 oCounter._Count = iCount
1032 Forms = oCounter
1033 Exit Function
1034 Else
1035 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
1036 End If
1038 Select Case VarType(pvIndex)
1039 Case vbString
1040 Set ofForm = Application.AllForms(Utils._Trim(pvIndex))
1041 Case Else
1042 iCount = Application._CountOpenForms()
1043 If iCount <= pvIndex Then Goto Trace_Error_Index
1044 Set ofForm = Application._CountOpenForms(pvIndex)
1045 End Select
1047 If IsNull(ofForm) Then Goto Trace_Error
1048 If ofForm.IsLoaded Then
1049 Set vForms = ofForm
1050 Else
1051 Set vForms = Nothing
1052 TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , ofForm._Name)
1053 Goto Exit_Function
1054 End If
1056 Exit_Function:
1057 Set Forms = vForms
1058 Utils._ResetCalledSub(cstThisSub)
1059 Exit Function
1060 Trace_Error:
1062 Set vForms = Nothing
1063 Goto Exit_Function
1064 Trace_Error_Index:
1066 Set vForms = Nothing
1067 Goto Exit_Function
1068 Error_Function:
1069 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1070 GoTo Exit_Function
1073 REM -----------------------------------------------------------------------------------------------------------------------
1074 Public Function getObject(Optional pvShortcut As Variant) As Variant
1075 ' Return the object described by pvShortcut ignoring its final property
1076 ' Example: "Forms!myForm!myControl.myProperty" => Controls(Forms("myForm"), "myControl"))
1081 If _ErrorHandler() Then On Local Error Goto Error_Function
1083 Utils._SetCalledSub(cstThisSub)
1084 If IsMissing(pvShortcut) Then Call _TraceArguments()
1085 If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function
1087 Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
1088 Dim sComponents() As String, sSubComponents() As String, sDialog As String
1089 Dim oDoc As Object
1090 Set vCurrentObject = Nothing
1091 sComponents = Split(Trim(pvShortcut), cstEXCLAMATION)
1092 If UBound(sComponents) = 0 Then Goto Trace_Error
1093 If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error
1095 Set oDoc = _A2B_.CurrentDocument()
1096 If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error
1097 End If
1099 sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
1102 Set vCurrentObject = New Collect
1103 Set vCurrentObject._This = vCurrentObject
1104 Select Case UCase(sComponents(0))
1108 End Select
1110 sSubComponents = Split(sComponents(iCurrentIndex), cstDOT)
1111 sComponents(iCurrentIndex) = Utils._Trim(sSubComponents(0))
1112 Select Case UBound(sSubComponents)
1113 Case 0
1114 sCurrentProperty = ""
1115 Case 1
1116 sCurrentProperty = sSubComponents(1)
1117 Case Else
1118 Goto Trace_Error
1119 End Select
1120 Select Case vCurrentObject._Type
1121 Case OBJCOLLECTION
1122 Select Case vCurrentObject._CollType
1123 Case COLLFORMS
1124 vCurrentObject = Application.AllForms(sComponents(iCurrentIndex))
1125 Case COLLALLDIALOGS
1126 sDialog = UCase(sComponents(iCurrentIndex))
1127 vCurrentObject = Application.AllDialogs(sDialog)
1128 If Not vCurrentObject.IsLoaded Then Goto Trace_Error
1129 Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog)
1130 Case COLLTEMPVARS
1132 vCurrentObject = Application.TempVars(sComponents(1))
1133 'Case Else
1134 End Select
1135 Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG
1136 vCurrentObject = vCurrentObject.Controls(sComponents(iCurrentIndex))
1137 End Select
1138 If sCurrentProperty <> "" Then vCurrentObject = vCurrentObject.getProperty(sCurrentProperty)
1139 Next iCurrentIndex
1141 Set getObject = vCurrentObject
1143 Exit_Function:
1144 Utils._ResetCalledSub(cstThisSub)
1145 Exit Function
1146 Trace_Error:
1148 Goto Exit_Function
1149 Error_Function:
1150 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1151 GoTo Exit_Function
1154 REM -----------------------------------------------------------------------------------------------------------------------
1155 Public Function getValue(Optional pvObject As Variant) As Variant
1156 ' getValue also interprets shortcut strings !!
1157 Dim vItem As Variant, sProperty As String
1159 If VarType(pvObject) = vbString Then
1161 Set vItem = getObject(pvObject)
1162 sProperty = Utils._FinalProperty(pvObject)
1163 If sProperty = "" Then sProperty = "Value" ' Default value if final property in shortcut is absent
1164 getValue = vItem.getProperty(sproperty)
1166 Else
1167 Set vItem = pvObject
1169 End If
1170 End Function ' getValue
1172 REM -----------------------------------------------------------------------------------------------------------------------
1173 Function HtmlEncode(ByVal pvString As Variant, ByVal Optional pvLength As Variant) As String
1174 ' Converts a string to an HTML-encoded string.
1176 If _ErrorHandler() Then On Local Error Goto Error_Function
1178 Utils._SetCalledSub(cstThisSub)
1180 HtmlEncode = ""
1182 Dim sOutput As String, l As Long, lLength As Long
1183 If IsMissing(pvLength) Then pvLength = 0
1184 If Not Utils._CheckArgument(pvString, 1, vbString) Then Goto Exit_Function
1185 If Not Utils._CheckArgument(pvLength, 1, _AddNumeric()) Then Goto Exit_Function
1187 sOutput = ""
1188 lLength = CLng(pvLength)
1190 For l = 1 To Len(pvString)
1193 Next l
1194 End If
1196 HtmlEncode = sOutput
1198 Exit_Function:
1199 Utils._ResetCalledSub(cstThisSub)
1200 Exit Function
1201 Error_Function:
1202 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1203 GoTo Exit_Function
1206 REM -----------------------------------------------------------------------------------------------------------------------
1207 Public Function OpenConnection ( _
1208 Optional pvComponent As Variant _
1209 , ByVal Optional pvUser As Variant _
1210 , ByVal Optional pvPassword As Variant _
1211 ) As Object
1213 ' Establish connection with the database designated in the currently open front-end (.odb) document
1214 ' Call template:
1216 ' Call stored in the OpenDocument event of the front-end database document
1217 'OR
1218 ' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms
1219 ' Call template:
1221 ' Call stored in the OpenDocument event of the document
1222 '
1223 ' User and Password arguments are obsolete (still tolerated)
1224 ' - because no mean has been found to connect protected db from .odb via API
1225 ' - because having multiple forms with multiple db's and multiple passwords is meaningless
1227 Dim oComponent As Object, oForms As Object, iCurrent As Integer
1228 Dim i As Integer, bFound As Boolean
1229 Dim vCurrentDoc() As Variant
1230 Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object
1231 Dim sDatabaseURL As String, oHandler As Object
1232 Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant
1233 Dim sFormName As String
1235 If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
1236 Set OpenConnection = Nothing
1238 If _ErrorHandler() Then On Local Error Goto Error_Function
1240 Utils._SetCalledSub(cstThisSub)
1241 If IsMissing(pvComponent) Then Call _TraceArguments()
1242 If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function
1243 Set oComponent = pvComponent
1246 Exit Function
1247 End If
1248 If IsMissing(pvUser) Then pvUser = ""
1249 If IsMissing(pvPassword) Then pvPassword = ""
1250 If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
1251 If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
1253 If Not IsArray(_A2B_.CurrentDoc) Then
1254 vCurrentDoc() = Array()
1256 Else
1257 vCurrentDoc() = _A2B_.CurrentDoc()
1258 End If
1260 ' Find index of entry to use for new connection
1261 With oComponent
1262 Select Case .ImplementationName
1264 iCurrent = 0
1267 iCurrent = 1
1268 Else ' Search entry already used earlier by same component
1269 bFound = False
1270 For i = 1 To UBound(vCurrentDoc)
1271 If Not IsEmpty(vCurrentDoc(i)) Then
1272 If vCurrentDoc(i).Active And vCurrentDoc(i).URL = .URL Then
1273 iCurrent = i
1274 bFound = True
1275 Exit For
1276 End If
1277 End If
1278 Next i
1279 End If
1280 If Not bFound Then
1282 ReDim Preserve vCurrentDoc(0 To iCurrent)
1283 End If
1284 End Select
1285 End With
1287 ' Initialize future entry
1288 Set vDocContainer = New DocContainer
1289 Set vDocContainer.Document = oComponent
1290 vDocContainer.Active = True
1291 vDocContainer.URL = oComponent.URL
1292 ' Initialize each DbContainer entry
1293 vDbContainers() = Array()
1294 TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
1295 Select Case oComponent.ImplementationName
1296 Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments
1297 vDbContainer = New DbContainer
1298 vDbContainer.FormName = ""
1299 Set vDbContainer.Database = New Database
1300 Set vDbContainer.Database._This = vDbContainer.Database
1301 With vDbContainer.Database
1302 If Not oComponent.CurrentController.IsConnected Then
1304 Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler)
1305 oComponent.CurrentController.connect()
1306 Else
1307 Set .Connection = oComponent.CurrentController.ActiveConnection
1308 End If
1309 vDocContainer.DbConnect = DBCONNECTBASE
1310 ._DbConnect = DBCONNECTBASE
1311 Set .MetaData = .Connection.MetaData
1312 ._LoadMetadata()
1314 ._ReadOnly = .MetaData.isReadOnly()
1315 Else
1316 ._ReadOnly = .Connection.isReadOnly() ' Always True in Mysql ??
1317 End If
1318 Set .Document = oComponent
1319 .Title = oComponent.Title
1320 .URL = vDocContainer.URL
1321 .Location = oComponent.Location
1323 Set vDbContainers(0) = vDbContainer
1324 TraceLog(TRACEANY, .Version, False)
1325 TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False)
1326 End With
1327 Case Else
1328 Set oForms = oComponent.CurrentController.Model.DrawPage.Forms
1332 vDbContainer = New DbContainer ' To make distinct entries !!
1333 sFormName = oForms.ElementNames(i)
1334 Set vDbContainer.Database = New Database
1335 Set vDbContainer.Database._This = vDbContainer.Database
1336 With vDbContainer.Database
1337 .FormName = sFormName
1338 vDbContainer.FormName = sFormName
1339 Set .Form = oForms.getByName(sFormName)
1340 Set .Connection = .Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO startup (not met in Linux)
1341 If Not IsNull(.Connection) Then
1342 Set .MetaData = .Connection.MetaData
1343 ._LoadMetadata()
1344 ._ReadOnly = .Connection.isReadOnly()
1345 TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
1346 End If
1347 Set .Document = oComponent
1348 .Title = oComponent.Title
1349 .URL = .Form.DataSourceName
1350 ._DbConnect = DBCONNECTFORM
1351 Set vDbContainers(i) = vDbContainer
1352 vDbContainers(i).FormName = sFormName
1353 TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False)
1354 End With
1355 Next i
1356 vDocContainer.DbConnect = DBCONNECTFORM
1357 End Select
1359 vDocContainer.DbContainers() = vDbContainers()
1360 Set vCurrentDoc(iCurrent) = vDocContainer
1362 _A2B_.CurrentDoc = vCurrentDoc
1363 Set OpenConnection = vDbContainers(0).Database
1366 Exit_Function:
1367 Utils._ResetCalledSub(cstThisSub)
1368 Exit Function
1369 Error_Function:
1370 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1371 Set _A2B_.CurrentDoc = Array()
1372 GoTo Exit_Function
1373 Error_MainForm:
1374 TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
1375 Set _A2B_.CurrentDoc = Array()
1376 GoTo Exit_Function
1377 Trace_Error:
1379 Goto Exit_Function
1382 REM -----------------------------------------------------------------------------------------------------------------------
1383 Public Function OpenDatabase ( _
1384 ByVal Optional pvDatabaseURL As Variant _
1385 , ByVal Optional pvUser As Variant _
1386 , ByVal Optional pvPassword As Variant _
1387 , ByVal Optional pvReadOnly As Variant _
1388 ) As Variant
1390 ' Return a database object based on input arguments:
1391 ' Call template:
1392 ' Call OpenDatabase("... databaseURL ..."[, "", "", True/False])
1393 ' pvDatabaseURL may be the name of a registered database or the URL of the targeted .odb file
1394 ' Might be called from any AOO/LibO application, independently from OpenConnection
1396 Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object
1397 Dim i As Integer, bFound As Boolean
1398 Dim sDatabaseURL As String
1400 If IsEmpty(_A2B_) Then ' First use of Access2Base in current AOO/LibO session
1401 Call Application._RootInit()
1402 TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
1403 End If
1404 Set OpenDatabase = Nothing
1406 If _ErrorHandler() Then On Local Error Goto Error_Function
1408 Utils._SetCalledSub(cstThisSub)
1409 If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function
1410 If pvDatabaseURL = "" Then Call _TraceArguments()
1411 If IsMissing(pvUser) Then pvUser = ""
1412 If IsMissing(pvPassword) Then pvPassword = ""
1413 If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
1414 If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
1415 If IsMissing(pvReadOnly) Then pvReadOnly = False
1416 If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function
1418 Set odbDatabase = New Database
1419 Set odbDatabase._This = odbDatabase
1420 odbDatabase._DbConnect = DBCONNECTANY
1423 sDbNames() = oBaseContext.getElementNames()
1424 bFound = False
1425 For i = 0 To UBound(sDbNames()) ' Enumerate registered databases and check non case-sensitive equality
1426 If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then
1427 sDatabaseURL = sDbNames(i)
1428 Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
1429 odbDatabase.Location = oBaseContext.getDatabaseLocation(sDbNames(i))
1430 bFound = True
1431 Exit For
1432 End If
1433 Next i
1434 If Not bFound Then
1435 sDatabaseURL = ConvertToURL(pvDatabaseURL)
1437 If Not FileExists(sDatabaseURL) Then Goto Trace_Error
1438 Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
1439 odbDatabase.Location = sDatabaseURL
1440 End If
1442 Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword)
1443 If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist
1444 Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
1445 odbDatabase._LoadMetadata()
1446 Else
1447 Goto Trace_Error
1448 End If
1450 odbDatabase.URL = sDatabaseURL
1452 If pvReadOnly Then
1453 odbDatabase.Connection.isReadOnly = True
1454 odbDatabase._ReadOnly = True
1455 End If
1457 Set OpenDatabase = odbDatabase
1459 TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False)
1460 TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False)
1463 Exit_Function:
1464 Utils._ResetCalledSub(cstThisSub)
1465 Exit Function
1466 Error_Function:
1467 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1468 GoTo Exit_Function
1469 Trace_Error:
1471 Goto Exit_Function
1474 REM -----------------------------------------------------------------------------------------------------------------------
1475 Public Function ProductCode()
1476 If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
1480 REM -----------------------------------------------------------------------------------------------------------------------
1481 Public Function setValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
1482 ' setValue also interprets shortcut strings !!
1483 Dim vItem As Variant, sProperty As String
1484 If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setValue")
1485 If VarType(pvObject) = vbString Then
1487 Set vItem = getObject(pvObject)
1488 sProperty = Utils._FinalProperty(pvObject)
1490 setValue = vItem.setProperty(sProperty, pvValue)
1492 Else
1493 Set vItem = pvObject
1495 End If
1496 End Function ' setValue
1498 REM -----------------------------------------------------------------------------------------------------------------------
1499 Public Function SysCmd(Optional pvAction As Variant _
1500 , Optional pvText As Variant _
1501 , Optional pvValue As Variant _
1502 ) As Variant
1503 ' Manage progress meter in the status bar
1504 ' Other values supported by MSAccess are ignored
1506 If _ErrorHandler() Then On Local Error Goto Error_Function
1508 Utils._SetCalledSub(cstThisSub)
1509 SysCmd = False
1511 Const cstMissing = -1
1512 Const cstBarLength = 350
1513 If IsMissing(pvAction) Then Call _TraceArguments()
1514 If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _
1515 acSysCmdAccessDir _
1516 , acSysCmdAccessVer _
1517 , acSysCmdClearHelpTopic _
1518 , acSysCmdClearStatus _
1519 , acSysCmdGetObjectState _
1520 , acSysCmdGetWorkgroupFile _
1521 , acSysCmdIniFile _
1522 , acSysCmdInitMeter _
1523 , acSysCmdProfile _
1524 , acSysCmdRemoveMeter _
1525 , acSysCmdRuntime _
1526 , acSysCmdSetStatus _
1527 , acSysCmdUpdateMeter _
1528 )) Then Goto Exit_Function
1529 If IsMissing(pvValue) Then pvValue = cstMissing
1530 If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function
1531 Select Case pvAction
1532 Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus
1533 If IsMissing(pvText) Then Call _TraceArguments()
1534 If Not Utils._CheckArgument(pvText, 2, vbString) Then Goto Exit_Function
1535 Case Else
1536 End Select
1537 If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function
1539 Dim vBar As Variant, iLen As Integer
1540 Set vBar = _A2B_.StatusBar
1541 Select Case pvAction
1542 Case acSysCmdAccessVer
1543 SysCmd = Application.Version()
1544 Goto Exit_Function
1545 Case acSysCmdSetStatus
1546 If pvValue <> cstMissing Then Goto Error_Arg
1547 iLen = Len(pvText)
1548 vBar = _NewBar()
1549 If Not IsNull(vBar) Then vBar.start(Iif(iLen >= cstBarLength, pvText, pvText & Space(cstBarLength - iLen)), 0)
1550 Case acSysCmdClearStatus
1551 If pvValue <> cstMissing Then Goto Error_Arg
1552 If Not IsNull(vBar) Then
1553 vBar.end()
1554 Set _A2B_.StatusBar = Nothing
1555 End If
1556 Case acSysCmdInitMeter
1557 If pvValue = cstMissing Then Call _TraceArguments()
1558 vBar = _NewBar()
1559 If Not IsNull(vBar) Then vBar.start(pvText, pvValue)
1560 Case acSysCmdUpdateMeter
1561 If pvValue = cstMissing Then Call _TraceArguments()
1562 If Not IsNull(vBar) Then ' Otherwise ignore !
1563 vBar.setValue(pvValue)
1565 End If
1566 Case acSysCmdRemoveMeter
1567 If Not IsNull(vBar) Then
1568 vBar.end()
1569 Set _A2B_.StatusBar = Nothing
1570 End If
1571 Case acSysCmdRuntime
1572 SysCmd = False
1573 Goto Exit_Function
1574 Case Else
1575 End Select
1577 SysCmd = True
1579 Exit_Function:
1580 Utils._ResetCalledSub(cstThisSub)
1581 Exit Function
1582 Error_Function:
1583 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1584 GoTo Exit_Function
1585 Error_Arg:
1587 Goto Exit_Function
1590 REM -----------------------------------------------------------------------------------------------------------------------
1591 Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant
1592 ' Return either a Collection or a TempVar object
1594 If _ErrorHandler() Then On Local Error Goto Error_Function
1596 Utils._SetCalledSub(cstThisSub)
1598 Dim iMode As Integer, vTempVars As Variant, bFound As Boolean
1599 Const cstCount = 0
1600 Const cstByIndex = 1
1601 Const cstByName = 2
1603 If IsMissing(pvIndex) Then
1604 iMode = cstCount
1605 Else
1606 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
1607 If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
1608 End If
1610 Set vTempVars = Nothing
1611 Select Case iMode
1612 Case cstCount ' Build Collection object
1613 Set vTempVars = New Collect
1614 With vTempVars
1615 ._This = vTempVars
1616 ._CollType = COLLTEMPVARS
1617 ._Count = _A2B_.TempVars.Count
1618 End With
1619 Case cstByIndex ' Build TempVar object
1622 Case cstByName
1623 bFound = _A2B_.hasItem(COLLTEMPVARS, pvIndex)
1624 If Not bFound Then Goto Trace_NotFound
1625 vTempVars = _A2B_.TempVars.Item(UCase(pvIndex))
1626 End Select
1628 Set TempVars = vTempVars
1630 Exit_Function:
1631 Utils._ResetCalledSub(cstThisSub)
1632 Exit Function
1633 Error_Function:
1634 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1635 GoTo Exit_Function
1636 Trace_Error_Index:
1638 Set vTempVars = Nothing
1639 Goto Exit_Function
1640 Trace_NotFound:
1641 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex))
1642 Goto Exit_Function
1645 REM -----------------------------------------------------------------------------------------------------------------------
1646 Public Function Version() As String
1647 Version = Utils._GetProductName()
1650 REM -----------------------------------------------------------------------------------------------------------------------
1651 REM --- PRIVATE FUNCTIONS ---
1652 REM -----------------------------------------------------------------------------------------------------------------------
1654 REM -----------------------------------------------------------------------------------------------------------------------
1655 Private Function _CollectNames(ByRef poCollection As Object, ByVal psPrefix As String) As Variant
1656 ' Return a "\;" separated list of hierarchical (prefixed with Prefix) and persistent names contained in Collection
1657 ' If one of those names refers to a folder, function is called recursively
1660 '
1661 Dim oObject As Object, vNamesList() As Variant, vPersistentList As Variant, i As Integer, sCollect(0 To 1) As String
1662 Dim sName As String, sType As String, sPrefix As String
1666 _CollectNames = sCollect()
1667 vPersistentList = Array()
1669 With poCollection
1670 If .getCount = 0 Then Exit Function
1671 vNamesList = .getElementNames()
1672 ReDim vPersistentList(0 To UBound(vNamesList))
1674 For i = 0 To UBound(vNamesList)
1675 sName = vNamesList(i)
1676 Set oObject = .getByName(sName)
1677 sType = oObject.getContentType()
1678 Select Case sType
1679 Case cstFormType
1680 vNamesList(i) = psPrefix & vNamesList(i)
1681 vPersistentList(i) = oObject.PersistentName
1682 Case "" ' Folder
1684 vNamesList(i) = sCollect(0)
1685 vPersistentList(i) = sCollect(1)
1686 Case Else
1687 End Select
1688 Next i
1690 End With
1692 Set oObject = Nothing
1693 sCollect(0) = Join(vNamesList, cstSeparator)
1694 sCollect(1) = Join(vPersistentList, cstSeparator)
1695 _CollectNames = sCollect()
1699 REM -----------------------------------------------------------------------------------------------------------------------
1700 Public Function _CountOpenForms(ByVal Optional piCountMax As Integer) As Variant
1701 ' Return # of active forms if no argument
1702 ' Return name of piCountMax-th open form if argument present
1704 Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant
1705 iAllCount = AllForms._Count
1706 iCount = 0
1709 Set ofForm = Application.AllForms(i)
1710 If ofForm._IsLoaded Then iCount = iCount + 1
1711 If Not IsMissing(piCountMax) Then
1712 If iCount = piCountMax + 1 Then
1713 _CountOpenForms = ofForm ' OO3.2 aborts when Set verb present ?!?
1714 Exit For
1715 End If
1716 End If
1717 Next i
1718 End If
1720 If IsMissing(piCountMax) Then _CountOpenForms = iCount
1724 REM -----------------------------------------------------------------------------------------------------------------------
1725 Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant
1726 REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use)
1727 REM With 2 arguments return the corresponding entry in Root
1729 Dim oCurrentDb As Object
1730 If IsEmpty(_A2B_) Then GoTo Trace_Error
1731 If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _
1732 Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry)
1733 If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb
1735 Exit_Function:
1736 Exit Function
1737 Trace_Error:
1739 Goto Exit_Function
1742 REM -----------------------------------------------------------------------------------------------------------------------
1743 Private Function _GetAllHierarchicalNames() As Variant
1744 ' Return the full hierarchical names list of a database document
1745 ' Get it from the vFormNamesList buffer if the latter is not empty
1747 Dim vNamesList As Variant, iCurrentDoc As Integer, vCurrentDoc As Variant
1748 Dim oForms As Object
1751 _GetAllHierarchicalNames = Array()
1753 ' Load complete list of names when Base document
1754 iCurrentDoc = _A2B_.CurrentDocIndex()
1755 If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) Else Exit Function
1756 If vCurrentDoc.DbConnect = DBCONNECTBASE Then
1757 If IsEmpty(vFormNamesList) Then
1758 Set oForms = vCurrentDoc.Document.getFormDocuments()
1759 vFormNamesList = _CollectNames(oForms, "")
1760 End If
1761 vNamesList = Split(vFormNamesList(0), cstSeparator)
1762 Else
1763 Exit Function
1764 End If
1766 _GetAllHierarchicalNames = vNamesList
1767 Set oForms = Nothing
1771 REM -----------------------------------------------------------------------------------------------------------------------
1772 Private Function _GetHierarchicalName(ByVal psPersistent As String) As String
1773 ' Return the full hierarchical name from the persistent name of a form/report
1775 Dim vPersistentList As Variant, vNamesList As Variant, i As Integer
1778 _GetHierarchicalName = ""
1780 ' Load complete list of names when Base document
1781 vNamesList = _GetAllHierarchicalNames()
1783 vPersistentList = Split(vFormNamesList(1), cstSeparator)
1785 ' Search in list
1786 For i = 0 To UBound(vPersistentList)
1787 If vPersistentList(i) = psPersistent Then
1788 _GetHierarchicalName = vNamesList(i)
1789 Exit For
1790 End If
1791 Next i
1795 REM -----------------------------------------------------------------------------------------------------------------------
1796 Private Function _NewBar() As Object
1797 ' Close current status bar, if any, and initialize new one
1799 Dim vBar As Variant, vWindow As Variant, vController As Object
1800 On Local Error Resume Next
1801 Set _NewBar = Nothing
1803 Set vBar = _A2B_.StatusBar
1804 If Not IsNull(vBar) Then
1806 Set _A2B_.StatusBar = Nothing
1807 End If
1809 Set vBar = Nothing
1810 Set vWindow = _SelectWindow()
1811 If IsNull(vWindow.Frame) Then Exit Function
1812 Select Case vWindow.WindowType
1813 Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow
1814 Case Else
1815 Exit Function
1816 End Select
1818 Set vController = vWindow.Frame.getCurrentController()
1820 Set vController = vWindow.Frame.getController()
1821 End If
1823 If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator()
1824 Set _A2B_.StatusBar = vBar
1825 Set _NewBar = vBar
1826 Exit Function
1830 REM -----------------------------------------------------------------------------------------------------------------------
1831 Private Function _NewCommandBar(psModule As String _
1832 , psToolbarName As String _
1833 , psToolbarFullName As String _
1834 , piBuiltin As Integer _
1835 ) As Object
1837 Dim oObject As Object
1838 Set oObject = New CommandBar
1839 With oObject
1840 ._This = oObject
1841 ._Type = OBJCOMMANDBAR
1842 ._Name = psToolbarName
1843 ._ResourceURL = psToolbarFullName
1844 ._Module = psModule
1845 ._BarBuiltin = piBuiltin
1852 Case Else : ._BarType = -1
1853 End Select
1854 End With
1855 Set _NewCommandBar = oObject
1856 Exit Function
1860 REM -----------------------------------------------------------------------------------------------------------------------
1861 Public Sub _RootInit(Optional ByVal pbForce As Boolean)
1862 ' Initialize _A2B_ global variable. Reinit forced if pbForce = True
1864 If IsMissing(pbForce) Then pbForce = False
1865 If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_
1869 </script:module>