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 ERRMETHOD = 1527 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 ERROVERFLOW = 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 Global Const ERRSUBFORMNOTFOUND = 1553 Global Const ERRWINDOW = 1554 Global Const ERRCOMPATIBILITY = 1555 Global Const ERRPRECISION = 1556 Global Const ERRMODULENOTFOUND = 1557 Global Const ERRPROCEDURENOTFOUND = 1558 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 DBMS_UNKNOWN = 0 Global Const DBMS_HSQLDB1 = 1 Global Const DBMS_HSQLDB2 = 2 Global Const DBMS_FIREBIRD = 3 Global Const DBMS_MSACCESS2003 = 4 Global Const DBMS_MSACCESS2007 = 5 Global Const DBMS_MYSQL = 6 Global Const DBMS_POSTGRES = 7 Global Const DBMS_SQLITE = 8 REM ----------------------------------------------------------------------------------------------------------------------- Global Const COLLALLDIALOGS = "ALLDIALOGS" Global Const COLLALLFORMS = "ALLFORMS" Global Const COLLALLMODULES = "ALLMODULES" Global Const COLLCOMMANDBARS = "COMMANDBARS" Global Const COLLCOMMANDBARCONTROLS = "COMMANDBARCONTROLS" 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 OBJCOMMANDBAR = "COMMANDBAR" Global Const OBJCOMMANDBARCONTROL = "COMMANDBARCONTROL" 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 OBJMODULE = "MODULE" 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 ----------------------------------------------------------------------------------------------------------------------- Global Const MODDOCUMENT = "DOCUMENT" Global Const MODGLOBAL = "GLOBAL" REM ----------------------------------------------------------------------------------------------------------------------- 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 ----------------------------------------------------------------------------------------------------------------------- REM --- Next variable is initialized to empty at each macro execution start --- REM --- Items in both lists correspond one by one --- Public vFormNamesList As Variant ' (0) Buffer of hierarchical form names => "\;" separated values ' (1) Buffer of persistent form names => "\;" separated values 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, bLocalStorage As Boolean Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object Dim vCurrentDocument As Variant 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 vCurrentDocument = Nothing If Not IsNull(_A2B_.CurrentDocument) Then Set vCurrentDocument = _A2B_.CurrentDocument.Document ElseIf Not IsNull(ThisComponent) Then Set vCurrentDocument = ThisComponent End If If IsNull(vCurrentDocument) Then Set oDocLibraries = Nothing vDocLibraries = Array() Else Set oDocLibraries = vCurrentDocument.DialogLibraries vDocLibraries = oDocLibraries.getElementNames() End If Set oMacLibraries = GlobalScope.DialogLibraries vMacLibraries = oMacLibraries.getElementNames() 'Remove Access2Base from the list If _A2B_.ExcludeA2B Then For i = 0 To UBound(vMacLibraries) If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = "" Next i End If vMacLibraries = Utils._TrimArray(vMacLibraries) If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library Set vAllDialogs = New Collect Set vAllDialogs._This = vAllDialogs vAllDialogs._CollType = COLLALLDIALOGS 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) bLocalStorage = True 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) bLocalStorage = False 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 Set vAllDialogs._This = vAllDialogs vAllDialogs._CollType = COLLALLDIALOGS 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 With vAllDialogs ._This = vAllDialogs ._Name = vDialogs(j) ._Shortcut = "Dialogs!" & vDialogs(j) Set ._Dialog = oLibDialog ._Library = sLibrary ._Storage = Iif(bLocalStorage, "DOCUMENT", "GLOBAL") End With 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 Const cstThisSub = "AllForms" Dim iIndex As Integer, vReturn As Variant Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object Dim ofForm As Object Dim vAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean Const cstSeparator = "\;" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Set vReturn = 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 Else iIndex = pvIndex End Select End If iCurrentDoc = _A2B_.CurrentDocIndex() If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) Else Goto Exit_Function End If ' Load complete list of hierarchical and persistent names when Base document If vCurrentDoc.DbConnect = DBCONNECTBASE Then vAllForms = _GetAllHierarchicalNames() ' Process when NO ARGUMENT If IsMissing(pvIndex) Then ' No argument Set oCounter = New Collect Set oCounter._This = oCounter oCounter._CollType = COLLALLFORMS If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = UBound(vAllForms) + 1 Set vReturn = oCounter Goto Exit_Function End If ' Process when ARGUMENT = STRING or INDEX => Initialize form object Set ofForm = New Form Set ofForm._This = ofForm Select Case vCurrentDoc.DbConnect Case DBCONNECTBASE ofForm._DocEntry = 0 ofForm._DbEntry = 0 If iIndex= -1 Then ' String argument vName = Utils._InList(Utils._Trim(pvIndex), vAllForms, True) If vName = False Then Goto Trace_Not_Found ofForm._Initialize(vName) Else If iIndex > UBound(vAllForms) Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense ofForm._Initialize(vAllForms(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 vReturn = ofForm Exit_Function: Set AllForms = vReturn 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 vReturn = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set vReturn = Nothing GoTo Exit_Function End Function ' AllForms V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function AllModules(ByVal Optional pvIndex As Variant, ByVal Optional pbAllModules As Boolean) As Variant ' Return either a Collection or a Module object ' The modules are selected only if library is loaded ' (UNPUBLISHED) pbAllModules = False collects only the modules located in the currently open document If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "AllModules" Utils._SetCalledSub(cstThisSub) Dim iMode As Integer, vModules() As Variant, i As Integer, j As Integer, iCount As Integer Dim oMacLibraries As Object, vAllModules As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean Dim sScript As String, sLibrary As String, oDocLibraries As Object, sStorage As String Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object Const cstCount = 0, cstByIndex = 1, cstByName = 2 Const cstDot = "." 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 ' Determine full name STORAGE.LIBRARY.MODULE vNames = Split(pvIndex, cstDot) If UBound(vNames) = 2 Then ElseIf UBound(vNames) = 1 Then pvIndex = MODDOCUMENT & cstDot & pvIndex ElseIf UBound(vNames) = 0 Then pvIndex = MODDOCUMENT & cstDot & "STANDARD" & cstDot & pvIndex Else GoTo Trace_Not_Found End If Else iMode = cstByIndex End If End If If IsMissing(pbAllModules) Then pbAllModules = True If Not Utils._CheckArgument(pbAllModules, 2, vbBoolean) Then Goto Exit_Function Set vAllModules = Nothing Set oDocLibraries = _A2B_.CurrentDocument.Document.BasicLibraries ' ThisComponent.BasicLibraries vDocLibraries = oDocLibraries.getElementNames() If pbAllModules Then Set oMacLibraries = GlobalScope.BasicLibraries vMacLibraries = oMacLibraries.getElementNames() 'Remove Access2Base from the list If _A2B_.ExcludeA2B Then For i = 0 To UBound(vMacLibraries) If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = "" Next i End If vMacLibraries = Utils._TrimArray(vMacLibraries) End If If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library Set vAllModules = New Collect Set vAllModules._This = vAllModules vAllModules._CollType = COLLALLMODULES vAllModules._Count = 0 Goto Exit_Function End If iCount = 0 For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1 bFound = False If i <= UBound(vDocLibraries) Then sLibrary = vDocLibraries(i) sStorage = MODDOCUMENT 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) sStorage = MODGLOBAL Set oDocMacLib = oMacLibraries End If If oDocMacLib.IsLibraryLoaded(sLibrary) Then Set oLibrary = oDocMacLib.getByName(sLibrary) If oLibrary.hasElements() Then vModules = oLibrary.getElementNames() Select Case iMode Case cstCount iCount = iCount + UBound(vModules) + 1 Case cstByIndex, cstByName For j = 0 To UBound(vModules) If iMode = cstByIndex Then If pvIndex = iCount Then bFound = True iCount = iCount + 1 Else If UCase(pvIndex) = UCase(sStorage & cstDot & sLibrary & cstDot & vModules(j)) Then bFound = True End If If bFound Then sScript = oLibrary.getByName(vModules(j)) ' Initiate Module object iCount = i Exit For End If Next j End Select End If End If If bFound Then Exit For Next i If iMode = cstCount Then Set vAllModules = New Collect Set vAllModules._This =vAllModules vAllModules._CollType = COLLALLMODULES vAllModules._Count = iCount Else If Not bFound Then If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found End If Set vAllModules = New Module Set vAllModules._This = vAllModules vAllModules._Name = vModules(j) vAllModules._LibraryName = sLibrary Set vAllModules._Library = oLibrary vAllModules._Storage = sStorage vAllModules._Script = sScript vAllModules._Initialize() End If Exit_Function: Set AllModules = vAllModules Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Not_Found: TraceError(TRACEFATAL, ERRMODULENOTFOUND, Utils._CalledSub(), 0, , pvIndex) Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set vModules = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set vModules = Nothing GoTo Exit_Function End Function ' AllModules V1.7.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 CommandBars(Optional ByVal pvIndex As Variant, Optional ByRef poWindow As Object) As Variant ' Return an object of type CommandBar indicated by its index or its name (CASE-INSENSITIVE string) ' If no pvIndex argument, return a Collection type ' (Unpublished) With poWindow, force the frame in which toolbars are detected If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "CommandBars" Utils._SetCalledSub(cstThisSub) Dim iObjectsCount As Integer, sObjectName As String, oObject As Object Dim oWindow As Object, iWindowType As Integer Dim i As Integer, j As Integer, k As Integer, bFound As Boolean Dim sSupportedModules() As Variant, vModules() As Variant, oModuleUI As Object Dim oToolbar As Object, sToolbarName As String, vUIElements() As Variant, sToolbarFullName As String, iBuiltin As Integer Const cstCustom = "CUSTOM" Set oObject = Nothing If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If iObjectsCount = 0 bFound = False If IsMissing(poWindow) Then Set oWindow = _SelectWindow() Else Set oWindow = poWindow If IsNull(oWindow.Frame) Then Goto Trace_WindowError ' List of 21 modules vModules = CreateUnoService("com.sun.star.frame.ModuleManager").getElementNames() iWindowType = oWindow.WindowType Select Case iWindowType ' Supported window types only Case acForm sSupportedModules = Array( "com.sun.star.sdb.FormDesign" ) Case acBasicIDE sSupportedModules = Array( "com.sun.star.script.BasicIDE" ) Case acDatabaseWindow sSupportedModules = Array( "com.sun.star.sdb.OfficeDatabaseDocument" ) Case acReport sSupportedModules = Array( "com.sun.star.sdb.TextReportDesign" ) Case acDocument Select Case oWindow.DocumentType Case docCalc : sSupportedModules = Array( "com.sun.star.sheet.SpreadsheetDocument" ) Case docWriter : sSupportedModules = Array( "com.sun.star.text.TextDocument" ) Case docImpress : sSupportedModules = Array( "com.sun.star.presentation.PresentationDocument" ) Case docDraw : sSupportedModules = Array( "com.sun.star.drawing.DrawingDocument" ) Case docMath : sSupportedModules = Array( "com.sun.star.formula.FormulaProperties" ) Case Else : sSupportedModules = Array() End Select Case acTable, acQuery sSupportedModules = Array( "com.sun.star.sdb.DataSourceBrowser" _ , "com.sun.star.sdb.TableDataView" _ ) Case acDiagram sSupportedModules = Array( "com.sun.star.sdb.RelationDesign" ) Case acWelcome sSupportedModules = Array( "com.sun.star.frame.StartModule" ) Case Else sSupportedModules = Array() End Select ' Find all standard and custom toolbars stored in LibO/AOO Base Set oModuleUI = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier") For k = 0 To UBound(vModules) For j = 0 To UBound(sSupportedModules) iBuiltin = 1 ' Default = builtin If vModules(k) = sSupportedModules(j) Then ' Supported modules only Set oToolbar = oModuleUI.getUIConfigurationManager(vModules(k)) vUIElements() = oToolbar.getUIElementsInfo(0) For i = 0 To UBound(vUIElements) sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") sToolbarName = Split(sToolbarFullName, "/")(2) If _IsLeft(UCase(sToolbarName), UCase(cstCustom)) Then sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") iBuiltin = 2 End If iObjectsCount = iObjectsCount + 1 Select Case True Case IsMissing(pvIndex) Case VarType(pvIndex) = vbString If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True Case Else If pvIndex < 0 Then Goto Trace_IndexError If pvIndex = iObjectsCount - 1 Then bFound = True End Select If bFound Then Set oObject = _NewCommandBar(vModules(k), sToolbarName, sToolbarFullName, iBuiltin) Set oObject._Window = oWindow.Frame Set oObject._Toolbar = oToolbar Goto Exit_Function End If Next i End If Next j Next k ' Find all (not builtin) toolbars stored in current document (typically forms) iBuiltin = 3 ' Stored in form itself Set oToolbar = oWindow.Frame.Controller.Model.getUIConfigurationManager vUIElements() = oToolbar.getUIElementsInfo(0) For i = 0 To UBound(vUIElements) sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") iObjectsCount = iObjectsCount + 1 Select Case True Case IsMissing(pvIndex) Case VarType(pvIndex) = vbString If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True Case Else If pvIndex = iObjectsCount - 1 Then bFound = True End Select If bFound Then Set oObject = _NewCommandBar("", sToolbarName, sToolbarFullName, iBuiltin) Set oObject._Window = oWindow.Frame Set oObject._Toolbar = oToolbar Goto Exit_Function End If Next i ' MISSING : CUSTOM POPUPS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Select Case True Case IsMissing(pvIndex) Set oObject = New Collect Set oObject._This = oObject oObject._CollType = COLLCOMMANDBARS oObject._Count = iObjectsCount Case VarType(pvIndex) = vbString Goto Trace_NotFound Case Else ' pvIndex is numeric Goto Trace_IndexError End Select Exit_Function: Set CommandBars = oObject Set oObject = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("COMMANDBAR"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function Trace_WindowError: TraceError(TRACEFATAL, ERRWINDOW, Utils._CalledSub(), 0) Goto Exit_Function End Function ' CommandBars V1,3,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 Const cstThisSub = "Controls" Utils._SetCalledSub(cstThisSub) If IsMissing(pvObject) Then Call _TraceArguments() If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments() Controls = EMPTY 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 Dim oPath As Object, sUser As String Set oPath = CreateUnoService("com.sun.star.util.PathSubstitution") sUser = oPath.getSubstituteVariableValue("$(username)") ' New since LibreOffice 5.2 CurrentUser = sUser 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 Set oCounter._This = oCounter oCounter._CollType = COLLFORMS 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 Else iCount = Application._CountOpenForms() If iCount <= pvIndex Then Goto Trace_Error_Index Set ofForm = Application._CountOpenForms(pvIndex) 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 getObject(Optional pvShortcut As Variant) As Variant ' Return the object described by pvShortcut ignoring its final property ' Example: "Forms!myForm!myControl.myProperty" => Controls(Forms("myForm"), "myControl")) Const cstEXCLAMATION = "!" Const cstDOT = "." If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "getObject" Utils._SetCalledSub(cstThisSub) If IsMissing(pvShortcut) Then Call _TraceArguments() If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String Dim sComponents() As String, sSubComponents() As String, sDialog As String Dim oDoc As Object Set vCurrentObject = Nothing sComponents = Split(Trim(pvShortcut), cstEXCLAMATION) If UBound(sComponents) = 0 Then Goto Trace_Error If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then Set oDoc = _A2B_.CurrentDocument() If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error End If sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) sComponents(UBound(sComponents)) = sSubComponents(0) ' Ignore final property, if any Set vCurrentObject = New Collect Set vCurrentObject._This = vCurrentObject Select Case UCase(sComponents(0)) Case "FORMS" : vCurrentObject._CollType = COLLFORMS Case "DIALOGS" : vCurrentObject._CollType = COLLALLDIALOGS Case "TEMPVARS" : vCurrentObject._CollType = COLLTEMPVARS End Select For iCurrentIndex = 1 To UBound(sComponents) ' Start parsing ... sSubComponents = Split(sComponents(iCurrentIndex), cstDOT) sComponents(iCurrentIndex) = Utils._Trim(sSubComponents(0)) Select Case UBound(sSubComponents) Case 0 sCurrentProperty = "" Case 1 sCurrentProperty = sSubComponents(1) Case Else Goto Trace_Error End Select Select Case vCurrentObject._Type Case OBJCOLLECTION Select Case vCurrentObject._CollType Case COLLFORMS vCurrentObject = Application.AllForms(sComponents(iCurrentIndex)) Case COLLALLDIALOGS sDialog = UCase(sComponents(iCurrentIndex)) vCurrentObject = Application.AllDialogs(sDialog) If Not vCurrentObject.IsLoaded Then Goto Trace_Error Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog) Case COLLTEMPVARS If UBound(sComponents) > 1 Then Goto Trace_Error vCurrentObject = Application.TempVars(sComponents(1)) 'Case Else End Select Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG vCurrentObject = vCurrentObject.Controls(sComponents(iCurrentIndex)) End Select If sCurrentProperty <> "" Then vCurrentObject = vCurrentObject.getProperty(sCurrentProperty) Next iCurrentIndex Set getObject = vCurrentObject Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' getObject V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function getValue(Optional pvObject As Variant) As Variant ' getValue also interprets shortcut strings !! Dim vItem As Variant, sProperty As String If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getValue") If VarType(pvObject) = vbString Then Utils._SetCalledSub("getValue") Set vItem = getObject(pvObject) sProperty = Utils._FinalProperty(pvObject) If sProperty = "" Then sProperty = "Value" ' Default value if final property in shortcut is absent getValue = vItem.getProperty(sproperty) Utils._ResetCalledSub("getValue") Else Set vItem = pvObject getValue = vItem.getProperty("Value") End If End Function ' getValue REM ----------------------------------------------------------------------------------------------------------------------- Function HtmlEncode(ByVal pvString As Variant, ByVal Optional pvLength As Variant) As String ' Converts a string to an HTML-encoded string. If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "HtmlEncode" Utils._SetCalledSub(cstThisSub) HtmlEncode = "" Dim sOutput As String, l As Long, lLength As Long If IsMissing(pvLength) Then pvLength = 0 If Not Utils._CheckArgument(pvString, 1, vbString) Then Goto Exit_Function If Not Utils._CheckArgument(pvLength, 1, _AddNumeric()) Then Goto Exit_Function sOutput = "" lLength = CLng(pvLength) If Len(pvString) > 0 Then For l = 1 To Len(pvString) If lLength > 0 And Len(sOutput) > lLength Then Exit For sOutput = sOutput & Utils._UTF8Encode(Mid(pvString, l, 1)) Next l End If HtmlEncode = sOutput Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' HtmlEncode V1.4.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 ._LoadMetadata() If .MetaData.DatabaseProductName = "MySQL" Then ._ReadOnly = .MetaData.isReadOnly() Else ._ReadOnly = .Connection.isReadOnly() ' Always True in Mysql ?? End If Set .Document = oComponent .Title = oComponent.Title .URL = vDocContainer.URL .Location = oComponent.Location ReDim vDbContainers(0 To 0) Set vDbContainers(0) = vDbContainer TraceLog(TRACEANY, .Version, 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 ._LoadMetadata() ._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 Variant ' Return a database object based on input arguments: ' Call template: ' Call OpenDatabase("... databaseURL ..."[, "", "", True/False]) ' pvDatabaseURL may 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 ' First use of Access2Base in current AOO/LibO session Call Application._RootInit() TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) End If 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) odbDatabase.Location = oBaseContext.getDatabaseLocation(sDbNames(i)) 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) odbDatabase.Location = 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 odbDatabase._LoadMetadata() 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, 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 setValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean ' setValue also interprets shortcut strings !! Dim vItem As Variant, sProperty As String If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setValue") If VarType(pvObject) = vbString Then Utils._SetCalledSub("setValue") Set vItem = getObject(pvObject) sProperty = Utils._FinalProperty(pvObject) If sProperty = "" Then sProperty = "Value" setValue = vItem.setProperty(sProperty, pvValue) Utils._ResetCalledSub("setValue") Else Set vItem = pvObject setValue = vItem.setProperty("Value", pvValue) End If End Function ' setValue 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 ._This = 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 ----------------------------------------------------------------------------------------------------------------------- Private Function _CollectNames(ByRef poCollection As Object, ByVal psPrefix As String) As Variant ' Return a "\;" separated list of hierarchical (prefixed with Prefix) and persistent names contained in Collection ' If one of those names refers to a folder, function is called recursively ' Result = 2 items array: (0) list of hierarchical names ' (1) list of persistent names ' Dim oObject As Object, vNamesList() As Variant, vPersistentList As Variant, i As Integer, sCollect(0 To 1) As String Dim sName As String, sType As String, sPrefix As String Const cstFormType = "application/vnd.oasis.opendocument.text" Const cstSeparator = "\;" _CollectNames = sCollect() vPersistentList = Array() With poCollection If .getCount = 0 Then Exit Function vNamesList = .getElementNames() ReDim vPersistentList(0 To UBound(vNamesList)) For i = 0 To UBound(vNamesList) sName = vNamesList(i) Set oObject = .getByName(sName) sType = oObject.getContentType() Select Case sType Case cstFormType vNamesList(i) = psPrefix & vNamesList(i) vPersistentList(i) = oObject.PersistentName Case "" ' Folder sCollect = _CollectNames(oObject, psPrefix & sName & "/") vNamesList(i) = sCollect(0) vPersistentList(i) = sCollect(1) Case Else End Select Next i End With Set oObject = Nothing sCollect(0) = Join(vNamesList, cstSeparator) sCollect(1) = Join(vPersistentList, cstSeparator) _CollectNames = sCollect() End Function ' _CollectNames V6.2.0 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 Dim oCurrentDb As Object If IsEmpty(_A2B_) Then GoTo Trace_Error If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _ Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry) If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb 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 _GetAllHierarchicalNames() As Variant ' Return the full hierarchical names list of a database document ' Get it from the vFormNamesList buffer if the latter is not empty Dim vNamesList As Variant, iCurrentDoc As Integer, vCurrentDoc As Variant Dim oForms As Object Const cstSeparator = "\;" _GetAllHierarchicalNames = Array() ' Load complete list of names when Base document iCurrentDoc = _A2B_.CurrentDocIndex() If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) Else Exit Function If vCurrentDoc.DbConnect = DBCONNECTBASE Then If IsEmpty(vFormNamesList) Then Set oForms = vCurrentDoc.Document.getFormDocuments() vFormNamesList = _CollectNames(oForms, "") End If vNamesList = Split(vFormNamesList(0), cstSeparator) Else Exit Function End If _GetAllHierarchicalNames = vNamesList Set oForms = Nothing End Function ' _GetAllHierarchicalNames V 6.2.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _GetHierarchicalName(ByVal psPersistent As String) As String ' Return the full hierarchical name from the persistent name of a form/report Dim vPersistentList As Variant, vNamesList As Variant, i As Integer Const cstSeparator = "\;" _GetHierarchicalName = "" ' Load complete list of names when Base document vNamesList = _GetAllHierarchicalNames() If UBound(vNamesList) < 0 Then Exit Function vPersistentList = Split(vFormNamesList(1), cstSeparator) ' Search in list For i = 0 To UBound(vPersistentList) If vPersistentList(i) = psPersistent Then _GetHierarchicalName = vNamesList(i) Exit For End If Next i End Function ' _GetHierarchicalName V 6.2.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 ----------------------------------------------------------------------------------------------------------------------- Private Function _NewCommandBar(psModule As String _ , psToolbarName As String _ , psToolbarFullName As String _ , piBuiltin As Integer _ ) As Object Dim oObject As Object Set oObject = New CommandBar With oObject ._This = oObject ._Type = OBJCOMMANDBAR ._Name = psToolbarName ._ResourceURL = psToolbarFullName ._Module = psModule ._BarBuiltin = piBuiltin Select Case UCase(Split(psToolbarFullName, "/")(1)) Case "MENUBAR" : ._BarType = msoBarTypeMenuBar Case "STATUSBAR" : ._BarType = msoBarTypeStatusBar Case "TOOLBAR" : ._BarType = msoBarTypeNormal Case "POPUP" : ._BarType = msoBarTypePopup Case "FLOATER" : ._BarType = msoBarTypeFloater Case Else : ._BarType = -1 End Select End With Set _NewCommandBar = oObject Exit Function End Function ' NewCommandBar V1.3.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _RootInit(Optional ByVal pbForce As Boolean) ' Initialize _A2B_ global variable. Reinit forced if pbForce = True If IsMissing(pbForce) Then pbForce = False If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_ End Sub ' _RootInit V1.1.0