Option Explicit 'DATABASE ' Name property ' Path property 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 ERRNOTDATABASE = 1501 Global Const ERRDBNOTCONNECTED = 1502 Global Const ERRMISSINGARGUMENTS = 1503 Global Const ERRWRONGARGUMENT = 1504 Global Const ERRMAINFORM = 1505 Global Const ERRSTANDALONE = 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 ERRMETHOD = 1527 Global Const ERRACTION = 1528 Global Const ERRSENDMAIL = 1529 Global Const ERRFORMYETOPEN = 1530 Global Const ERRMETHOD = 1531 Global Const ERRPROPERTYINIT = 1532 Global Const ERRFILENOTCREATED = 1533 Global Const ERRDIALOGNOTFOUND = 1534 Global Const ERRDIALOGUNDEFINED = 1535 Global Const ERRDIALOGSTARTED = 1536 Global Const ERRDIALOGNOTSTARTED = 1537 Global Const ERRRECORDSETNODATA = 1538 Global Const ERRRECORDSETCLOSED = 1539 Global Const ERRRECORDSETRANGE = 1540 Global Const ERRRECORDSETFORWARD = 1541 Global Const ERRFIELDNULL = 1542 Global Const ERRFILEACCESS = 1543 Global Const ERRMEMOLENGTH = 1544 Global Const ERRNOTACTIONQUERY = 1545 Global Const ERRNOTUPDATABLE = 1546 Global Const ERRUPDATESEQUENCE = 1547 Global Const ERRNOTNULLABLE = 1548 Global Const ERRROWDELETED = 1549 Global Const ERRRECORDSETCLONE = 1550 Global Const ERRQUERYDEFDELETED = 1551 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 ' Single values 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 CurrentDb() As Object ' Array of database objects -{0] = Base file, [1..N] = Writer files 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.Utils._CheckArgument(pvIndex, 1, Utils.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 '_CurrentDb().Document.DialogLibraries vDocLibraries = oDocLibraries.getElementNames() Set oMacLibraries = DialogLibraries vMacLibraries = oMacLibraries.getElementNames() 'Remove Access2Base from the list For i = 0 To UBound(vMacLibraries) If vMacLibraries(i) = "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.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.Utils._CheckArgument(pvIndex, 1, Utils.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 oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object Set oDatabase = _CurrentDb() If Not oDatabase._Standalone Then Set oForms = oDatabase.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 oDatabase._Standalone Then oCounter._Count = 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, sSub As String, vName As Variant Select Case oDatabase._Standalone Case False sAllForms() = oForms.getElementNames() If iIndex= -1 Then ' String argument vName = Utils._InList(Utils.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 True If iIndex = -1 Then If UCase(Utils.Utils._Trim(pvIndex)) <> UCase(oDatabase.FormName) Then Goto Trace_Not_Found ElseIf iIndex <> 0 Then Goto Trace_Error_Index End If vName = oDatabase.FormName 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.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_.CurrentDb(.) 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, oCurrent As Object bFound = False Set CurrentDb = Nothing With _A2B_ If Not IsArray(.CurrentDb) Then Goto Exit_Function If UBound(.CurrentDb) < 0 Then Goto Exit_Function For i = 1 To UBound(.CurrentDb) ' [0] reserved to database .odb document Set oCurrent = .CurrentDb(i) If IsMissing(pvURL) Then ' Not on 1 single line ?!? If Utils.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 .CurrentDb(i).URL = sURL Then Set CurrentDb = oCurrent bFound = True Exit For End If Next i If Not bFound Then If Not IsNull(.CurrentDb(0)) Then Set CurrentDb = .CurrentDb(0) End If End With Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' CurrentDb V0.9.5 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._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._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._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._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._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._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._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._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._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._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.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, Utils.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.Utils._AddNumeric(vbString)) Then Goto Exit_Function End If Select Case VarType(pvIndex) Case vbString Set ofForm = Application.AllForms(Utils.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, , 1) 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 Sub OpenConnection ( _ Optional pvComponent As Variant _ , ByVal Optional pvUser As Variant _ , ByVal Optional pvPassword As Variant _ ) ' 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) form (V0.8.0) ' Call template: ' Call OpenConnection(ThisComponent[, "", ""]) ' Call stored in the OpenDocument event of the standalone form Dim odbDatabase As Variant, oComponent As Object, oForm As Object, iCurrent As Integer Dim i As Integer, bFound As Boolean Dim vCurrentDb() As Variant If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session If _ErrorHandler() Then On Local Error Goto Error_Sub Const cstThisSub = "OpenConnection" Utils._SetCalledSub(cstThisSub) If IsMissing(pvComponent) Then Call _TraceArguments() If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Sub Set oComponent = pvComponent If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 1) Exit Sub End If If IsMissing(pvUser) Then pvUser = "" If IsMissing(pvPassword) Then pvPassword = "" If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Sub If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Sub If Not IsArray(_A2B_.CurrentDb) Then vCurrentDb = Array() Else vCurrentDb = _A2B_.CurrentDb Set odbDatabase = New Database Select Case oComponent.ImplementationName Case "com.sun.star.comp.dba.ODatabaseDocument" If Not oComponent.CurrentController.IsConnected Then oComponent.CurrentController.Connect(pvUser, pvPassword) Set odbDatabase.Connection = oComponent.CurrentController.ActiveConnection odbDatabase._Standalone = False Case "SwXTextDocument" Set oForm = oComponent.CurrentController.Model.DrawPage.Forms If oForm.Count <> 1 Then Goto Error_MainForm odbDatabase.FormName = oForm.ElementNames(0) odbDatabase.Form = oForm.getByName(odbDatabase.FormName) Set odbDatabase.Connection = odbDatabase.Form.ActiveConnection odbDatabase._Standalone = True Case Else TraceError(TRACEFATAL, ERRNOTDATABASE, Utils._CalledSub(), 0, , 1) End Select If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist Set odbDatabase.MetaData = odbDatabase.Connection.MetaData End If Set odbDatabase.Document = oComponent odbDatabase.Title = oComponent.Title odbDatabase.URL = oComponent.URL If UBound(vCurrentDb) < 0 Then ' NOT ON 1 SINGLE LINE !!! Redim vCurrentDb(0 To 0) End If Select Case odbDatabase._Standalone ' Find entry to use for new connection Case True If UBound(vCurrentDb) <= 0 Then iCurrent = 1 Else ' Search entry already used earlier by same component bFound = False For i = 1 To UBound(vCurrentDb) If Not IsEmpty(vCurrentDb(i)) Then If vCurrentDb(i)._Standalone And vCurrentDb(i).URL = odbDatabase.URL Then iCurrent = i bFound = True Exit For End If End If Next i End If If Not bFound Then iCurrent = UBound(vCurrentDb) + 1 ' No entry found, increment array ReDim Preserve vCurrentDb(0 To iCurrent) End If Set vCurrentDb(iCurrent) = odbDatabase Case False Set vCurrentDb(0) = odbDatabase End Select _A2B_.CurrentDb = vCurrentDb TraceLog(TRACEANY, Utils._GetProductName() & " - Access2Base " & _A2B_.VersionNumber, False) If IsNull(odbDatabase.Connection) Then Goto Trace_Error TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False) Exit_Sub: Utils._ResetCalledSub(cstThisSub) Exit Sub Error_Sub: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set _A2B_.CurrentDb = Array() GoTo Exit_Sub Error_MainForm: TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title) Set _A2B_.CurrentDb = Array() GoTo Exit_Sub Trace_Error: TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) Goto Exit_Sub End Sub ' OpenConnection V0.9.1 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.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.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, oDb As Object, iLen As Integer Set oDb = _CurrentDb() Set vBar = oDb.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 oDb.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 oDb.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 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 V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _CurrentDb() As Variant REM Same as CurrentDb() except that it generates an error if database not connected (internal use) Dim odbDatabase As Variant Set odbDatabase = Application.CurrentDb() 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 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _DFunction(ByVal psFunction As String _ , ByVal psExpr As String _ , ByVal psDomain As String _ , ByVal pvCriteria As Variant _ , ByVal Optional pvOrderClause As Variant _ ) As Variant 'Arguments: psFunction an optional aggregate function ' psExpr: an SQL expression [might contain an aggregate function] ' psDomain: a table- or queryname ' pvCriteria: an optional WHERE clause ' pcOrderClause: an optional order clause incl. "DESC" if relevant If _ErrorHandler() Then On Local Error GoTo Error_Function Dim oResult As Object 'To retrieve the value to find. Dim vResult As Variant 'Return value for function. Dim sSql As String 'SQL statement. Dim oStatement As Object 'For CreateStatement method Dim sExpr As String 'For inclusion of aggregate function vResult = Null If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")" sSql = "SELECT " & sExpr & " AS XXRESULTFIELDXX FROM " & psDomain If pvCriteria <> "" Then sSql = sSql & " WHERE " & pvCriteria End If If pvOrderClause <> "" Then sSql = sSql & " ORDER BY " & pvOrderClause End If sSql = Utils._ReplaceSquareBrackets(sSql) 'Substitute [] by quote string 'Lookup the value. Dim oDatabase As Object Set oStatement = _CurrentDb.Connection.createStatement() With oStatement .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY .EscapeProcessing = False Set oResult = .executeQuery(sSql) If Not IsNull(oResult) And Not IsEmpty(oResult) Then If Not oResult.next() Then Goto Exit_Function vResult = Utils._getResultSetColumnValue(oResult, 1) End If End With Exit_Function: 'Assign the returned value. _DFunction = vResult Set oResult = Nothing Set oStatement = Nothing Exit Function Error_Function: TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) Goto Exit_Function End Function ' DFunction V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _NewBar() As Object ' Close current status bar, if any, and initialize new one Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object On Local Error Resume Next Set _NewBar = Nothing Set oDb = Application._CurrentDb() Set vBar = oDb.StatusBar If Not IsNull(vBar) Then If Utils._hasUNOMethod(vBar, "end") Then vBar.end() Set oDb.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 ' 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 oDb.StatusBar = vBar Set _NewBar = vBar Exit Function End Function ' _NewBar V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _RootInit() ' Initialize _A2B_ global variable Dim vRoot As Root 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 End With End If End Sub ' _RootInit V0.9.1