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" 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" 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 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 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 = Application._CurrentDoc() If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDoc(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 Set ofForm._This = ofForm 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 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(Optional pvURL As String) As Object ' Returns _A2B_.CurrentDoc(.).Database as an object to allow access to its properties ' Parameter only for internal use Const cstThisSub = "CurrentDb" Utils._SetCalledSub(cstThisSub) Dim i As Integer, bFound As Boolean, sURL As String, iCurrentDoc As Integer, oCurrentDoc As Object bFound = False Set CurrentDb = Nothing With _A2B_ If Not IsArray(.CurrentDoc) Then Goto Exit_Function If UBound(.CurrentDoc) < 0 Then Goto Exit_Function iCurrentDoc = _CurrentDoc() If iCurrentDoc >= 0 Then Set CurrentDb = .CurrentDoc(iCurrentDoc).DbContainers(0).Database End With 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).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.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() 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 Const cstThisSub = "SysCmd" Utils._SetCalledSub(cstThisSub) SysCmd = False If _ErrorHandler() Then On Local Error Goto Error_Function 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 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 Set ofForm = New Form Set ofForm._This = ofForm 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 Dim odbDatabase As Variant If IsMissing(piDocEntry) Then Set odbDatabase = Application.CurrentDb() Else With _A2B_ If Not IsArray(.CurrentDoc) Then Goto Trace_Error If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error If piDocEntry > UBound(.CurrentDoc) Then Goto Trace_Error If piDbEntry > UBound(.CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error Set odbDatabase = .CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database End With End If If IsNull(odbDatabase) Then GoTo Trace_Error Exit_Function: Set _CurrentDb = odbDatabase Exit Function Trace_Error: TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Goto Exit_Function End Function ' _CurrentDb V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _CurrentDoc(Optional pvURL As String) As Integer ' Returns the entry in _A2B_.CurrentDoc(...) referring to the current document Dim i As Integer, bFound As Boolean, sURL As String bFound = False _CurrentDoc = -1 ' Convention for _A2B_ not initalized or no entry found With _A2B_ If Not IsArray(.CurrentDoc) Then Goto Exit_Function If UBound(.CurrentDoc) < 0 Then Goto Exit_Function For i = 1 To UBound(.CurrentDoc) ' [0] reserved to database .odb document If IsMissing(pvURL) Then ' Not on 1 single line ?!? If Utils._hasUNOProperty(ThisComponent, "URL") Then sURL = ThisComponent.URL Else Exit For ' f.i. ThisComponent = Basic IDE ... End If Else sURL = pvURL ' To support the SelectObject action End If If .CurrentDoc(i).URL = sURL Then _CurrentDoc = i bFound = True Exit For End If Next i If Not bFound Then If Not IsNull(.CurrentDoc(0)) Then _CurrentDoc = 0 End If End With Exit_Function: Exit Function End Function ' _CurrentDoc V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _hasDialog(ByVal psName As String) As Boolean ' Return True if psName if in the collection of started dialogs Dim oDialog As Object On Local Error Goto Error_Function ' Whatever ErrorHandler ! Set oDialog = _A2B_.Dialogs.Item(UCase(psName)) _hasDialog = True Exit_Function: Exit Function Error_Function: ' Item by key aborted _hasDialog = False GoTo Exit_Function End Function ' _hasDialog 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() ' Initialize _A2B_ global variable Dim vRoot As Root, vCurrentDoc() As Variant If IsEmpty(_A2B_) Then _A2B_ = vRoot With _A2B_ .VersionNumber = Access2Base_Version .ErrorHandler = True .MinimalTraceLevel = 0 .TraceLogs() = Array() .TraceLogCount = 0 .TraceLogLast = 0 .TraceLogMaxEntries = 0 .CalledSub = "" .Introspection = Nothing Set .FindRecord = Nothing Set .StatusBar = Nothing Set .Dialogs = New Collection vCurrentDoc() = Array() ReDim vCurrentDoc(0 To 0) Set vCurrentDoc(0) = Nothing Set .CurrentDoc() = vCurrentDoc() End With End If End Sub ' _RootInit V1.1.0