f55a0a54b2
Redesign of CurrentDb, CurrentDoc interfaces. Creation of new Root_.xba class module. Console logs, TempVars and Dialog collections are unchanged. Change-Id: I573a75e8fb54b277aef84d4518cc8e5cc21d7270
1243 lines
No EOL
50 KiB
XML
1243 lines
No EOL
50 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="Application" 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 Explicit
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const TRACEDEBUG = "DEBUG" ' To report values of variables
|
|
Global Const TRACEINFO = "INFO" ' To report any event
|
|
Global Const TRACEWARNING = "WARNING" ' To report some abnormal event
|
|
Global Const TRACEERRORS = "ERROR" ' To report user errors - Default value
|
|
Global Const TRACEFATAL = "FATAL" ' To report programmer errors - f.i. Wrong argument
|
|
Global Const TRACEABORT = "ABORT" ' To report Access2Base internal errors
|
|
Global Const TRACEANY = "===>" ' Always reported
|
|
' ERRORs, FATALs and ABORTs are also displayed in a MsgBox (except on specific request)
|
|
' FATALs and ABORTs interrupt the program execution
|
|
|
|
Global Const ERRINIT = 1500
|
|
Global Const ERRDBNOTCONNECTED = 1501
|
|
Global Const ERRMISSINGARGUMENTS = 1502
|
|
Global Const ERRWRONGARGUMENT = 1503
|
|
Global Const ERRMAINFORM = 1504
|
|
Global Const ERRMETHOD = 1505
|
|
Global Const ERRFILEACCESS = 1506
|
|
Global Const ERRFORMNOTIDENTIFIED = 1507
|
|
Global Const ERRFORMNOTFOUND = 1508
|
|
Global Const ERRFORMNOTOPEN = 1509
|
|
Global Const ERRDFUNCTION = 1510
|
|
Global Const ERROPENFORM = 1511
|
|
Global Const ERRPROPERTY = 1512
|
|
Global Const ERRPROPERTYVALUE = 1513
|
|
Global Const ERRINDEXVALUE = 1514
|
|
Global Const ERRCOLLECTION = 1515
|
|
Global Const ERRPROPERTYNOTARRAY = 1516
|
|
Global Const ERRCONTROLNOTFOUND = 1517
|
|
Global Const ERRNOACTIVEFORM = 1518
|
|
Global Const ERRDATABASEFORM = 1519
|
|
Global Const ERRFOCUSINGRID = 1520
|
|
Global Const ERRNOGRIDINFORM = 1521
|
|
Global Const ERRFINDRECORD = 1522
|
|
Global Const ERRSQLSTATEMENT = 1523
|
|
Global Const ERROBJECTNOTFOUND = 1524
|
|
Global Const ERROPENOBJECT = 1525
|
|
Global Const ERRCLOSEOBJECT = 1526
|
|
Global Const ERRACTION = 1528
|
|
Global Const ERRSENDMAIL = 1529
|
|
Global Const ERRFORMYETOPEN = 1530
|
|
Global Const ERRPROPERTYINIT = 1531
|
|
Global Const ERRFILENOTCREATED = 1532
|
|
Global Const ERRDIALOGNOTFOUND = 1533
|
|
Global Const ERRDIALOGUNDEFINED = 1534
|
|
Global Const ERRDIALOGSTARTED = 1535
|
|
Global Const ERRDIALOGNOTSTARTED = 1536
|
|
Global Const ERRRECORDSETNODATA = 1537
|
|
Global Const ERRRECORDSETCLOSED = 1538
|
|
Global Const ERRRECORDSETRANGE = 1539
|
|
Global Const ERRRECORDSETFORWARD = 1540
|
|
Global Const ERRFIELDNULL = 1541
|
|
Global Const ERRMEMOLENGTH = 1542
|
|
Global Const ERRNOTACTIONQUERY = 1543
|
|
Global Const ERRNOTUPDATABLE = 1544
|
|
Global Const ERRUPDATESEQUENCE = 1545
|
|
Global Const ERRNOTNULLABLE = 1546
|
|
Global Const ERRROWDELETED = 1547
|
|
Global Const ERRRECORDSETCLONE = 1548
|
|
Global Const ERRQUERYDEFDELETED = 1549
|
|
Global Const ERRTABLEDEFDELETED = 1550
|
|
Global Const ERRTABLECREATION = 1551
|
|
Global Const ERRFIELDCREATION = 1552
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection)
|
|
Global Const DBCONNECTFORM = 2 ' Connection from a database-aware form (OpenConnection)
|
|
Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const COLLALLDIALOGS = "ALLDIALOGS"
|
|
Global Const COLLALLFORMS = "ALLFORMS"
|
|
Global Const COLLCONTROLS = "CONTROLS"
|
|
Global Const COLLFORMS = "FORMS"
|
|
Global Const COLLFIELDS = "FIELDS"
|
|
Global Const COLLPROPERTIES = "PROPERTIES"
|
|
Global Const COLLQUERYDEFS = "QUERYDEFS"
|
|
Global Const COLLRECORDSETS = "RECORDSETS"
|
|
Global Const COLLTABLEDEFS = "TABLEDEFS"
|
|
Global Const COLLTEMPVARS = "TEMPVARS"
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const OBJAPPLICATION = "APPLICATION"
|
|
Global Const OBJCOLLECTION = "COLLECTION"
|
|
Global Const OBJCONTROL = "CONTROL"
|
|
Global Const OBJDATABASE = "DATABASE"
|
|
Global Const OBJDIALOG = "DIALOG"
|
|
Global Const OBJEVENT = "EVENT"
|
|
Global Const OBJFIELD = "FIELD"
|
|
Global Const OBJFORM = "FORM"
|
|
Global Const OBJOPTIONGROUP = "OPTIONGROUP"
|
|
Global Const OBJPROPERTY = "PROPERTY"
|
|
Global Const OBJQUERYDEF = "QUERYDEF"
|
|
Global Const OBJRECORDSET = "RECORDSET"
|
|
Global Const OBJSUBFORM = "SUBFORM"
|
|
Global Const OBJTABLEDEF = "TABLEDEF"
|
|
Global Const OBJTEMPVAR = "TEMPVAR"
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const CTLCONTROL = "CONTROL" ' ClassId
|
|
Global Const CTLCHECKBOX = "CHECKBOX" ' 5
|
|
Global Const CTLCOMBOBOX = "COMBOBOX" ' 7
|
|
Global Const CTLCOMMANDBUTTON = "COMMANDBUTTON" ' 2
|
|
Global Const CTLCURRENCYFIELD = "CURRENCYFIELD" ' 18
|
|
Global Const CTLDATEFIELD = "DATEFIELD" ' 15
|
|
Global Const CTLFILECONTROL = "FILECONTROL" ' 12
|
|
Global Const CTLFIXEDTEXT = "FIXEDTEXT" ' 10
|
|
Global Const CTLGRIDCONTROL = "GRIDCONTROL" ' 11
|
|
Global Const CTLGROUPBOX = "GROUPBOX" ' 8
|
|
Global Const CTLHIDDENCONTROL = "HIDDENCONTROL" ' 13
|
|
Global Const CTLIMAGEBUTTON = "IMAGEBUTTON" ' 4
|
|
Global Const CTLIMAGECONTROL = "IMAGECONTROL" ' 14
|
|
Global Const CTLLISTBOX = "LISTBOX" ' 6
|
|
Global Const CTLNAVIGATIONBAR = "NAVIGATIONBAR" ' 22
|
|
Global Const CTLNUMERICFIELD = "NUMERICFIELD" ' 17
|
|
Global Const CTLPATTERNFIELD = "PATTERNFIELD" ' 19
|
|
Global Const CTLRADIOBUTTON = "RADIOBUTTON" ' 3
|
|
Global Const CTLSCROLLBAR = "SCROLLBAR" ' 20
|
|
Global Const CTLSPINBUTTON = "SPINBUTTON" ' 21
|
|
Global Const CTLTEXTFIELD = "TEXTFIELD" ' 9
|
|
Global Const CTLTIMEFIELD = "TIMEFIELD" ' 16
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const CTLFORMATTEDFIELD = "FORMATTEDFIELD" ' 9 (idem TextField)
|
|
Global Const CTLFIXEDLINE = "FIXEDLINE" ' 24 (forced)
|
|
Global Const CTLPROGRESSBAR = "PROGRESSBAR" ' 23 (forced)
|
|
Global Const CTLSUBFORM = "SUBFORMCONTROL" ' None
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Global Const CTLPARENTISFORM = "FORM"
|
|
Global Const CTLPARENTISDIALOG = "DIALOG"
|
|
Global Const CTLPARENTISSUBFORM = "SUBFORM"
|
|
Global Const CTLPARENTISGRID = "GRID"
|
|
Global Const CTLPARENTISGROUP = "OPTIONGROUP"
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Type Root
|
|
ErrorHandler As Boolean
|
|
MinimalTraceLevel As Integer
|
|
TraceLogs() As Variant
|
|
TraceLogCount As Integer
|
|
TraceLogLast As Integer
|
|
TraceLogMaxEntries As Integer
|
|
CalledSub As String
|
|
Introspection As Object ' com.sun.star.beans.Introspection
|
|
VersionNumber As String ' Actual Access2Base version number
|
|
FindRecord As Object
|
|
StatusBar As Object
|
|
Dialogs As Object ' Collection
|
|
TempVars As Object ' Collection
|
|
CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents
|
|
End Type
|
|
|
|
Type DocContainer
|
|
Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
|
|
Active As Boolean
|
|
DbConnect As Integer ' DBCONNECTxxx constants
|
|
URL As String
|
|
DbContainers() As Variant ' One entry by (data-aware) form
|
|
End Type
|
|
|
|
Type DbContainer
|
|
FormName As String ' name of data-aware form
|
|
Database As Object ' Database type
|
|
End Type
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function AllDialogs(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return either a Collection or a Dialog object
|
|
' The dialogs are selected only if library is loaded
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "AllDialogs"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Dim iMode As Integer, vDialogs() As Variant, i As Integer, j As Integer, iCount As Integer
|
|
Dim oMacLibraries As Object, vAllDialogs As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
|
|
Dim oLibDialog As Object, sLibrary As String, oDocLibraries As Object
|
|
Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
|
|
Const cstCount = 0
|
|
Const cstByIndex = 1
|
|
Const cstByName = 2
|
|
Const cstSepar = "!"
|
|
|
|
If IsMissing(pvIndex) Then
|
|
iMode = cstCount
|
|
Else
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
|
|
End If
|
|
|
|
Set vAllDialogs = Nothing
|
|
|
|
Set oDocLibraries = ThisComponent.DialogLibraries
|
|
vDocLibraries = oDocLibraries.getElementNames()
|
|
Set oMacLibraries = DialogLibraries
|
|
vMacLibraries = oMacLibraries.getElementNames()
|
|
'Remove Access2Base from the list
|
|
For i = 0 To UBound(vMacLibraries)
|
|
If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
|
|
Next i
|
|
vMacLibraries = Utils._TrimArray(vMacLibraries)
|
|
|
|
If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
|
|
Set vAllDialogs = New Collect
|
|
vAllDialogs._CollType = COLLALLDIALOGS
|
|
vAllDialogs._ParentType = OBJAPPLICATION
|
|
vAllDialogs._ParentName = ""
|
|
vAllDialogs._Count = 0
|
|
Goto Exit_Function
|
|
End If
|
|
|
|
vNames = Array()
|
|
iCount = 0
|
|
For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1
|
|
bFound = False
|
|
If i <= UBound(vDocLibraries) Then
|
|
sLibrary = vDocLibraries(i)
|
|
Set oDocMacLib = oDocLibraries
|
|
' Sometimes library not loaded as should ??
|
|
If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
|
|
Else
|
|
sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
|
|
Set oDocMacLib = oMacLibraries
|
|
End If
|
|
If oDocMacLib.IsLibraryLoaded(sLibrary) Then
|
|
Set oLibrary = oDocMacLib.getByName(sLibrary)
|
|
If oLibrary.hasElements() Then
|
|
vDialogs = oLibrary.getElementNames()
|
|
Select Case iMode
|
|
Case cstCount
|
|
iCount = iCount + UBound(vDialogs) + 1
|
|
Case cstByIndex, cstByName
|
|
For j = 0 To UBound(vDialogs)
|
|
If iMode = cstByIndex Then
|
|
If pvIndex = iCount Then bFound = True
|
|
iCount = iCount + 1
|
|
Else
|
|
If UCase(pvIndex) = UCase(vDialogs(j)) Then bFound = True
|
|
End If
|
|
If bFound Then
|
|
Set oLibDialog = oLibrary.getByName(vDialogs(j)) ' Create Dialog object
|
|
Exit For
|
|
End If
|
|
Next j
|
|
End Select
|
|
End If
|
|
End If
|
|
If bFound Then Exit For
|
|
Next i
|
|
|
|
If iMode = cstCount Then
|
|
Set vAllDialogs = New Collect
|
|
vAllDialogs._CollType = COLLALLDIALOGS
|
|
vAllDialogs._ParentType = OBJAPPLICATION
|
|
vAllDialogs._ParentName = ""
|
|
vAllDialogs._Count = iCount
|
|
Else
|
|
If Not bFound Then
|
|
If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found
|
|
End If
|
|
Set vAllDialogs = New Dialog
|
|
vAllDialogs._Name = vDialogs(j)
|
|
vAllDialogs._Shortcut = "Dialogs!" & vDialogs(j)
|
|
Set vAllDialogs._Dialog = oLibDialog
|
|
End If
|
|
|
|
Exit_Function:
|
|
Set AllDialogs = vAllDialogs
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Trace_Not_Found:
|
|
TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
|
|
Goto Exit_Function
|
|
Trace_Error_Index:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
|
Set vDialogs = Nothing
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
Set vDialogs = Nothing
|
|
GoTo Exit_Function
|
|
End Function ' AllDialogs V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function AllForms(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string)
|
|
' Easiest use for standalone forms: AllForms(0)
|
|
' If no argument, return a Collection type
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "AllForms"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
Dim iIndex As Integer, vAllForms As Variant
|
|
Set vAllForms = Nothing
|
|
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
Select Case VarType(pvIndex)
|
|
Case vbString
|
|
iIndex = -1
|
|
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
|
|
iIndex = pvIndex
|
|
End Select
|
|
End If
|
|
|
|
Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
|
|
iCurrentDoc = _A2B_.CurrentDocIndex()
|
|
If iCurrentDoc >= 0 Then
|
|
vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc)
|
|
Else
|
|
Goto Exit_Function
|
|
End If
|
|
If vCurrentDoc.DbConnect = DBCONNECTBASE Then Set oForms = vCurrentDoc.Document.getFormDocuments()
|
|
' Process when NO ARGUMENT
|
|
If IsMissing(pvIndex) Then ' No argument
|
|
Set oCounter = New Collect
|
|
oCounter._CollType = COLLALLFORMS
|
|
oCounter._ParentType = OBJAPPLICATION
|
|
oCounter._ParentName = ""
|
|
If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = oForms.getCount()
|
|
Set vAllForms = oCounter
|
|
Goto Exit_Function
|
|
End If
|
|
|
|
' Process when ARGUMENT = STRING or INDEX => Initialize form object
|
|
Dim ofForm As Object
|
|
Set ofForm = New Form
|
|
Dim sAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean
|
|
Select Case vCurrentDoc.DbConnect
|
|
Case DBCONNECTBASE
|
|
sAllForms() = oForms.getElementNames()
|
|
ofForm._DocEntry = 0
|
|
ofForm._DbEntry = 0
|
|
If iIndex= -1 Then ' String argument
|
|
vName = Utils._InList(Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive
|
|
If vName = False Then Goto Trace_Not_Found
|
|
ofForm._Initialize(vName)
|
|
Else
|
|
If iIndex + 1 > oForms.getCount() Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense
|
|
ofForm._Initialize(sAllForms(iIndex))
|
|
End If
|
|
Case DBCONNECTFORM
|
|
With vCurrentDoc
|
|
If iIndex = -1 Then
|
|
bFound = False
|
|
For i = 0 To UBound(vCurrentDoc.DbContainers)
|
|
Set oDatabase = vCurrentDoc.DbContainers(i).Database
|
|
If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then
|
|
bFound = True
|
|
ofForm._DbEntry = i
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_Not_Found
|
|
ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then
|
|
Goto Trace_Error_Index
|
|
Else
|
|
ofForm._DbEntry = iIndex
|
|
Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database
|
|
End If
|
|
End With
|
|
vName = oDatabase.FormName
|
|
ofForm._DocEntry = iCurrentDoc
|
|
ofForm._Initialize(vName)
|
|
End Select
|
|
|
|
Set vAllForms = ofForm
|
|
|
|
Exit_Function:
|
|
Set AllForms = vAllForms
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Trace_Not_Found:
|
|
TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
|
|
Goto Exit_Function
|
|
Trace_Error_Index:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
|
Set vAllForms = Nothing
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
Set vAllForms = Nothing
|
|
GoTo Exit_Function
|
|
End Function ' AllForms V0.9.0
|
|
|
|
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
|
|
|
|
If IsEmpty(_A2B_) Then Goto Exit_Sub
|
|
|
|
Const cstThisSub = "CloseConnection"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Call _A2B_.CloseConnection()
|
|
|
|
Exit_Sub:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Sub
|
|
End Sub ' CloseConnection V1.2.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIndex As Variant) As Variant
|
|
' Return an object of type Control indicated by either its index (integer) or its name (CASE-INSENSITIVE string)
|
|
' The 1st argument pvObject can be either
|
|
' an object of type FORM (1)
|
|
' a main form name as string
|
|
' an object of type SUBFORM (2)
|
|
' The Form property in the returned variant contains a SUBFORM type
|
|
' an object of type CONTROL and subtype GRIDCONTROL (3)
|
|
' an object of type OPTIONGROUP (4) 2nd argument, if any, must be numeric
|
|
' If no pvIndex argument, return a Collection type
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Dim vObject As Object, vEMPTY As variant
|
|
Const cstThisSub = "Controls"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
If IsMissing(pvObject) Then Call _TraceArguments()
|
|
If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
|
|
Controls = vEMPTY
|
|
|
|
If VarType(pvObject) = vbString Then
|
|
Set vObject = Forms(pvObject)
|
|
If IsNull(vObject) Then Goto Exit_Function
|
|
Else
|
|
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM, OBJOPTIONGROUP, CTLGRIDCONTROL)) Then Goto Exit_Function
|
|
Set vObject = pvObject
|
|
End If
|
|
|
|
If IsMissing(pvIndex) Then
|
|
Controls = vObject.Controls()
|
|
Else
|
|
If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
Controls = vObject.Controls(pvIndex)
|
|
End If
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEERROR, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' Controls V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CurrentDb() As Object
|
|
' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties
|
|
|
|
Const cstThisSub = "CurrentDb"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Set CurrentDb = Nothing
|
|
If IsEmpty(_A2B_) Then GoTo Exit_Function
|
|
Set CurrentDb = _A2B_.CurrentDb()
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
End Function ' CurrentDb V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CurrentUser() As String
|
|
|
|
Const cstWindows = 1
|
|
Const cstUnix = 4
|
|
Select Case GetGuiType()
|
|
Case cstWindows
|
|
CurrentUser = Environ("USERNAME")
|
|
Case cstUnix
|
|
CurrentUser = Environ("USER")
|
|
Case Else
|
|
CurrentUser = ""
|
|
End Select
|
|
|
|
End Function ' CurrentUser V0.9.1
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DAvg( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return average of scope
|
|
Const cstThisSub = "DAvg"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DAvg
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DCount( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return # of occurrences of scope
|
|
Const cstThisSub = "DCount"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DCount
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DLookup( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
, ByVal Optional pvOrderClause As Variant _
|
|
) As Variant
|
|
|
|
' Return a value within a table
|
|
'Arguments: psExpr: an SQL expression
|
|
' psDomain: a table- or queryname
|
|
' pvCriteria: an optional WHERE clause
|
|
' pcOrderClause: an optional order clause incl. "DESC" if relevant
|
|
'Return: Value of the psExpr if found, else Null.
|
|
'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
|
|
'Examples:
|
|
' 1. To find the last value, include DESC in the OrderClause, e.g.:
|
|
' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
|
|
' 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
|
|
' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
|
|
|
|
Const cstThisSub = "DLookup"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _
|
|
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
|
|
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
|
|
)
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DLookup
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMax( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return maximum of scope
|
|
Const cstThisSub = "DMax"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMax
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMin( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return minimum of scope
|
|
Const cstThisSub = "DMin"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMin
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDev( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "DStDev"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDev
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDevP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "DStDevP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDevP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DSum( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return sum of scope
|
|
Const cstThisSub = "DSum"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DSum
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVar( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "DVar"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVar
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVarP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "DVarP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVarP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Events(Optional poEvent As Variant) As Variant
|
|
' Return an event object corresponding with actual event
|
|
|
|
Dim vEvent As Variant
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "Events"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Set vEvent = Nothing
|
|
If IsMissing(poEvent) Then Goto Exit_Function
|
|
If IsNull(poEvent) Then Goto Exit_Function
|
|
|
|
If Not Utils._CheckArgument(poEvent, 1, vbObject, , False) Then Goto Exit_Function ' No error handling in CheckArgument
|
|
If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error
|
|
Set vEvent = New Event
|
|
vEvent._Initialize(poEvent)
|
|
|
|
Exit_Function:
|
|
Set Events = vEvent
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEWARNING, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_Error:
|
|
' Errors are not displayed to avoid display infinite cycling
|
|
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent)))
|
|
Set vEvent = Nothing
|
|
Goto Exit_Function
|
|
End Function ' Events V0.9.1
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Forms(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string)
|
|
' The concerned form must be loaded.
|
|
' If no argument, return a Collection type
|
|
|
|
Const cstThisSub = "Forms"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Dim ofForm As Object, oCounter As Variant, vForms As Variant, oIndex As Object
|
|
Set vForms = Nothing
|
|
|
|
Dim iCount As Integer
|
|
If IsMissing(pvIndex) Then
|
|
iCount = Application._CountOpenForms()
|
|
Set oCounter = New Collect
|
|
oCounter._CollType = COLLFORMS
|
|
oCounter._ParentType = OBJAPPLICATION
|
|
oCounter._ParentName = ""
|
|
oCounter._Count = iCount
|
|
Forms = oCounter
|
|
Exit Function
|
|
Else
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Select Case VarType(pvIndex)
|
|
Case vbString
|
|
Set ofForm = Application.AllForms(Utils._Trim(pvIndex))
|
|
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
|
|
iCount = Application._CountOpenForms()
|
|
If iCount <= pvIndex Then Goto Trace_Error_Index
|
|
Set ofForm = Application._CountOpenForms(pvIndex)
|
|
Case Else
|
|
End Select
|
|
|
|
If IsNull(ofForm) Then Goto Trace_Error
|
|
If ofForm.IsLoaded Then
|
|
Set vForms = ofForm
|
|
Else
|
|
Set vForms = Nothing
|
|
TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , ofForm._Name)
|
|
Goto Exit_Function
|
|
End If
|
|
|
|
Exit_Function:
|
|
Set Forms = vForms
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Trace_Error:
|
|
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvIndex))
|
|
Set vForms = Nothing
|
|
Goto Exit_Function
|
|
Trace_Error_Index:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
|
Set vForms = Nothing
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' Forms V0.9.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function OpenConnection ( _
|
|
Optional pvComponent As Variant _
|
|
, ByVal Optional pvUser As Variant _
|
|
, ByVal Optional pvPassword As Variant _
|
|
) As Object
|
|
|
|
' Establish connection with the database designated in the currently open front-end (.odb) document
|
|
' Call template:
|
|
' Call OpenConnection(ThisDatabaseDocument[, "", ""])
|
|
' Call stored in the OpenDocument event of the front-end database document
|
|
'OR
|
|
' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms
|
|
' Call template:
|
|
' Call OpenConnection(ThisComponent[, "", ""])
|
|
' Call stored in the OpenDocument event of the document
|
|
'
|
|
' User and Password arguments are obsolete (still tolerated)
|
|
' - because no mean has been found to connect protected db from .odb via API
|
|
' - because having multiple forms with multiple db's and multiple passwords is meaningless
|
|
|
|
Dim oComponent As Object, oForms As Object, iCurrent As Integer
|
|
Dim i As Integer, bFound As Boolean
|
|
Dim vCurrentDoc() As Variant
|
|
Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object
|
|
Dim sDatabaseURL As String, oHandler As Object
|
|
Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant
|
|
Dim sFormName As String
|
|
|
|
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
|
|
Set OpenConnection = Nothing
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "OpenConnection"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(pvComponent) Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function
|
|
Set oComponent = pvComponent
|
|
If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then
|
|
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent))
|
|
Exit Function
|
|
End If
|
|
If IsMissing(pvUser) Then pvUser = ""
|
|
If IsMissing(pvPassword) Then pvPassword = ""
|
|
If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
|
|
If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
|
|
|
|
If Not IsArray(_A2B_.CurrentDoc) Then
|
|
vCurrentDoc() = Array()
|
|
Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document
|
|
Else
|
|
vCurrentDoc() = _A2B_.CurrentDoc()
|
|
End If
|
|
|
|
' Find index of entry to use for new connection
|
|
With oComponent
|
|
Select Case .ImplementationName
|
|
Case "com.sun.star.comp.dba.ODatabaseDocument"
|
|
iCurrent = 0
|
|
Case Else ' "SwXTextDocument", "ScModelObj"
|
|
If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session
|
|
iCurrent = 1
|
|
Else ' Search entry already used earlier by same component
|
|
bFound = False
|
|
For i = 1 To UBound(vCurrentDoc)
|
|
If Not IsEmpty(vCurrentDoc(i)) Then
|
|
If vCurrentDoc(i).Active And vCurrentDoc(i).URL = .URL Then
|
|
iCurrent = i
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next i
|
|
End If
|
|
If Not bFound Then
|
|
iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array
|
|
ReDim Preserve vCurrentDoc(0 To iCurrent)
|
|
End If
|
|
End Select
|
|
End With
|
|
|
|
' Initialize future entry
|
|
Set vDocContainer = New DocContainer
|
|
Set vDocContainer.Document = oComponent
|
|
vDocContainer.Active = True
|
|
vDocContainer.URL = oComponent.URL
|
|
' Initialize each DbContainer entry
|
|
vDbContainers() = Array()
|
|
TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
|
|
Select Case oComponent.ImplementationName
|
|
Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments
|
|
vDbContainer = New DbContainer
|
|
vDbContainer.FormName = ""
|
|
Set vDbContainer.Database = New Database
|
|
Set vDbContainer.Database._This = vDbContainer.Database
|
|
With vDbContainer.Database
|
|
If Not oComponent.CurrentController.IsConnected Then
|
|
Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler")
|
|
Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler)
|
|
oComponent.CurrentController.connect()
|
|
Else
|
|
Set .Connection = oComponent.CurrentController.ActiveConnection
|
|
End If
|
|
vDocContainer.DbConnect = DBCONNECTBASE
|
|
._DbConnect = DBCONNECTBASE
|
|
Set .MetaData = .Connection.MetaData
|
|
._ReadOnly = .Connection.isReadOnly()
|
|
Set .Document = oComponent
|
|
.Title = oComponent.Title
|
|
.URL = vDocContainer.URL
|
|
ReDim vDbContainers(0 To 0)
|
|
Set vDbContainers(0) = vDbContainer
|
|
TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
|
|
TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False)
|
|
End With
|
|
Case Else
|
|
Set oForms = oComponent.CurrentController.Model.DrawPage.Forms
|
|
If oForms.Count < 1 Then Goto Error_MainForm
|
|
ReDim vDbContainers(0 To oForms.Count - 1)
|
|
For i = 0 To oForms.Count - 1
|
|
vDbContainer = New DbContainer ' To make distinct entries !!
|
|
sFormName = oForms.ElementNames(i)
|
|
Set vDbContainer.Database = New Database
|
|
Set vDbContainer.Database._This = vDbContainer.Database
|
|
With vDbContainer.Database
|
|
.FormName = sFormName
|
|
vDbContainer.FormName = sFormName
|
|
Set .Form = oForms.getByName(sFormName)
|
|
Set .Connection = .Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO startup (not met in Linux)
|
|
If Not IsNull(.Connection) Then
|
|
Set .MetaData = .Connection.MetaData
|
|
._ReadOnly = .Connection.isReadOnly()
|
|
TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
|
|
End If
|
|
Set .Document = oComponent
|
|
.Title = oComponent.Title
|
|
.URL = .Form.DataSourceName
|
|
._DbConnect = DBCONNECTFORM
|
|
Set vDbContainers(i) = vDbContainer
|
|
vDbContainers(i).FormName = sFormName
|
|
TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False)
|
|
End With
|
|
Next i
|
|
vDocContainer.DbConnect = DBCONNECTFORM
|
|
End Select
|
|
|
|
vDocContainer.DbContainers() = vDbContainers()
|
|
Set vCurrentDoc(iCurrent) = vDocContainer
|
|
|
|
_A2B_.CurrentDoc = vCurrentDoc
|
|
Set OpenConnection = vDbContainers(0).Database
|
|
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
Set _A2B_.CurrentDoc = Array()
|
|
GoTo Exit_Function
|
|
Error_MainForm:
|
|
TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
|
|
Set _A2B_.CurrentDoc = Array()
|
|
GoTo Exit_Function
|
|
Trace_Error:
|
|
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
|
|
Goto Exit_Function
|
|
End Function ' OpenConnection V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function OpenDatabase ( _
|
|
ByVal Optional pvDatabaseURL As Variant _
|
|
, ByVal Optional pvUser As Variant _
|
|
, ByVal Optional pvPassword As Variant _
|
|
, ByVal Optional pvReadOnly As Variant _
|
|
) As Object
|
|
|
|
' Return a database object based on input arguments:
|
|
' Call template:
|
|
' Call OpenConnection("... databaseURL ..."[, "", "", True/False])
|
|
' pvDatabaseURL maby be the name of a registered database or the URL of the targeted .odb file
|
|
' Might be called from any AOO/LibO application, independently from OpenConnection
|
|
|
|
Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object
|
|
Dim i As Integer, bFound As Boolean
|
|
Dim sDatabaseURL As String
|
|
|
|
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
|
|
Set OpenDatabase = Nothing
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "OpenDatabase"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If pvDatabaseURL = "" Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function
|
|
If IsMissing(pvUser) Then pvUser = ""
|
|
If IsMissing(pvPassword) Then pvPassword = ""
|
|
If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
|
|
If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
|
|
If IsMissing(pvReadOnly) Then pvReadOnly = False
|
|
If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function
|
|
|
|
Set odbDatabase = New Database
|
|
Set odbDatabase._This = odbDatabase
|
|
odbDatabase._DbConnect = DBCONNECTANY
|
|
|
|
Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
|
|
sDbNames() = oBaseContext.getElementNames()
|
|
bFound = False
|
|
For i = 0 To UBound(sDbNames() ' Enumerate registered databases and check non case-sensitive equality
|
|
If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then
|
|
sDatabaseURL = sDbNames(i)
|
|
Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then
|
|
sDatabaseURL = ConvertToURL(pvDatabaseURL)
|
|
If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error
|
|
If Not FileExists(sDatabaseURL) Then Goto Trace_Error
|
|
Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
|
|
End If
|
|
|
|
Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword)
|
|
If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist
|
|
Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
|
|
Else
|
|
Goto Trace_Error
|
|
End If
|
|
|
|
odbDatabase.URL = sDatabaseURL
|
|
|
|
If pvReadOnly Then
|
|
odbDatabase.Connection.isReadOnly = True
|
|
odbDatabase._ReadOnly = True
|
|
End If
|
|
|
|
Set OpenDatabase = odbDatabase
|
|
|
|
TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
|
|
TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False)
|
|
TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False)
|
|
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_Error:
|
|
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
|
|
Goto Exit_Function
|
|
End Function ' OpenDatabase V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function ProductCode()
|
|
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
|
|
ProductCode = "Access2Base " & _A2B_.VersionNumber
|
|
End Function ' ProductCode V0.9.1
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function SysCmd(Optional pvAction As Variant _
|
|
, Optional pvText As Variant _
|
|
, Optional pvValue As Variant _
|
|
) As Variant
|
|
' Manage progress meter in the status bar
|
|
' Other values supported by MSAccess are ignored
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "SysCmd"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
SysCmd = False
|
|
|
|
Const cstMissing = -1
|
|
Const cstBarLength = 350
|
|
If IsMissing(pvAction) Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _
|
|
acSysCmdAccessDir _
|
|
, acSysCmdAccessVer _
|
|
, acSysCmdClearHelpTopic _
|
|
, acSysCmdClearStatus _
|
|
, acSysCmdGetObjectState _
|
|
, acSysCmdGetWorkgroupFile _
|
|
, acSysCmdIniFile _
|
|
, acSysCmdInitMeter _
|
|
, acSysCmdProfile _
|
|
, acSysCmdRemoveMeter _
|
|
, acSysCmdRuntime _
|
|
, acSysCmdSetStatus _
|
|
, acSysCmdUpdateMeter _
|
|
)) Then Goto Exit_Function
|
|
If IsMissing(pvValue) Then pvValue = cstMissing
|
|
If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function
|
|
Select Case pvAction
|
|
Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus
|
|
If IsMissing(pvText) Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvText, 2, vbString) Then Goto Exit_Function
|
|
Case Else
|
|
End Select
|
|
If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function
|
|
|
|
Dim vBar As Variant, iLen As Integer
|
|
Set vBar = _A2B_.StatusBar
|
|
Select Case pvAction
|
|
Case acSysCmdAccessVer
|
|
SysCmd = Application.Version()
|
|
Goto Exit_Function
|
|
Case acSysCmdSetStatus
|
|
If pvValue <> cstMissing Then Goto Error_Arg
|
|
iLen = Len(pvText)
|
|
vBar = _NewBar()
|
|
If Not IsNull(vBar) Then vBar.start(Iif(iLen >= cstBarLength, pvText, pvText & Space(cstBarLength - iLen)), 0)
|
|
Case acSysCmdClearStatus
|
|
If pvValue <> cstMissing Then Goto Error_Arg
|
|
If Not IsNull(vBar) Then
|
|
vBar.end()
|
|
Set _A2B_.StatusBar = Nothing
|
|
End If
|
|
Case acSysCmdInitMeter
|
|
If pvValue = cstMissing Then Call _TraceArguments()
|
|
vBar = _NewBar()
|
|
If Not IsNull(vBar) Then vBar.start(pvText, pvValue)
|
|
Case acSysCmdUpdateMeter
|
|
If pvValue = cstMissing Then Call _TraceArguments()
|
|
If Not IsNull(vBar) Then ' Otherwise ignore !
|
|
vBar.setValue(pvValue)
|
|
If Len(pvText) > 0 Then vBar.setText(pvText)
|
|
End If
|
|
Case acSysCmdRemoveMeter
|
|
If Not IsNull(vBar) Then
|
|
vBar.end()
|
|
Set _A2B_.StatusBar = Nothing
|
|
End If
|
|
Case acSysCmdRuntime
|
|
SysCmd = False
|
|
Goto Exit_Function
|
|
Case Else
|
|
End Select
|
|
|
|
SysCmd = True
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Error_Arg:
|
|
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(3, pvValue))
|
|
Goto Exit_Function
|
|
End Function ' SysCmd V0.9.1
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return either a Collection or a TempVar object
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "TempVars"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Dim iMode As Integer, vTempVars As Variant, bFound As Boolean
|
|
Const cstCount = 0
|
|
Const cstByIndex = 1
|
|
Const cstByName = 2
|
|
|
|
If IsMissing(pvIndex) Then
|
|
iMode = cstCount
|
|
Else
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
|
|
End If
|
|
|
|
Set vTempVars = Nothing
|
|
Select Case iMode
|
|
Case cstCount ' Build Collection object
|
|
Set vTempVars = New Collect
|
|
With vTempVars
|
|
._CollType = COLLTEMPVARS
|
|
._Count = _A2B_.TempVars.Count
|
|
End With
|
|
Case cstByIndex ' Build TempVar object
|
|
If pvIndex < 0 Or pvIndex >= _A2B_.TempVars.Count Then Goto Trace_Error_Index
|
|
Set vTempVars = _A2B_.TempVars.Item(pvIndex + 1) ' Builtin collections start at 1
|
|
Case cstByName
|
|
bFound = _A2B_.hasItem(COLLTEMPVARS, pvIndex)
|
|
If Not bFound Then Goto Trace_NotFound
|
|
vTempVars = _A2B_.TempVars.Item(UCase(pvIndex))
|
|
End Select
|
|
|
|
Set TempVars = vTempVars
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_Error_Index:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
|
Set vTempVars = Nothing
|
|
Goto Exit_Function
|
|
Trace_NotFound:
|
|
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex))
|
|
Goto Exit_Function
|
|
End Function ' TempVars V1.2.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Version() As String
|
|
Version = Utils._GetProductName()
|
|
End Function ' Version V0.9.1
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- PRIVATE FUNCTIONS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _CountOpenForms(ByVal Optional piCountMax As Integer) As Variant
|
|
' Return # of active forms if no argument
|
|
' Return name of piCountMax-th open form if argument present
|
|
|
|
Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant
|
|
iAllCount = AllForms._Count
|
|
iCount = 0
|
|
If iAllCount > 0 Then
|
|
For i = 0 To iAllCount - 1
|
|
Set ofForm = Application.AllForms(i)
|
|
If ofForm.IsLoaded Then iCount = iCount + 1
|
|
If Not IsMissing(piCountMax) Then
|
|
If iCount = piCountMax + 1 Then
|
|
_CountOpenForms = ofForm ' OO3.2 aborts when Set verb present ?!?
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next i
|
|
End If
|
|
|
|
If IsMissing(piCountMax) Then _CountOpenForms = iCount
|
|
|
|
End Function ' CountOpenForms V1.1.0
|
|
|
|
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
|
|
|
|
If IsEmpty(_A2B_) Then GoTo Trace_Error
|
|
If IsMissing(piDocEntry) Then Set _CurrentDb = Application.CurrentDb() _
|
|
Else Set _CurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry)
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Trace_Error:
|
|
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1)
|
|
Goto Exit_Function
|
|
End Function ' _CurrentDb V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _NewBar() As Object
|
|
' Close current status bar, if any, and initialize new one
|
|
|
|
Dim vBar As Variant, vWindow As Variant, vController As Object
|
|
On Local Error Resume Next
|
|
Set _NewBar = Nothing
|
|
|
|
Set vBar = _A2B_.StatusBar
|
|
If Not IsNull(vBar) Then
|
|
If Utils._hasUNOMethod(vBar, "end") Then vBar.end()
|
|
Set _A2B_.StatusBar = Nothing
|
|
End If
|
|
|
|
Set vBar = Nothing
|
|
Set vWindow = _SelectWindow()
|
|
If IsNull(vWindow.Frame) Then Exit Function
|
|
Select Case vWindow.WindowType
|
|
Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow
|
|
Case Else
|
|
Exit Function
|
|
End Select
|
|
If Utils._hasUNOMethod(vWindow.Frame, "getCurrentController") Then
|
|
Set vController = vWindow.Frame.getCurrentController()
|
|
ElseIf Utils._hasUNOMethod(vWindow.Frame, "getController") Then
|
|
Set vController = vWindow.Frame.getController()
|
|
End If
|
|
|
|
If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator()
|
|
Set _A2B_.StatusBar = vBar
|
|
Set _NewBar = vBar
|
|
Exit Function
|
|
|
|
End Function ' _NewBar V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub _RootInit(Optional ByVal pbForce As Boolean)
|
|
' Initialize _A2B_ global variable. Reinit forced if pbForce = True
|
|
|
|
Dim vRoot As Root, vCurrentDoc() As Variant
|
|
If IsMissing(pbForce) Then pbForce = False
|
|
If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_
|
|
|
|
End Sub ' _RootInit V1.1.0
|
|
</script:module> |