REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Compatible Option ClassModule Option Explicit REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be COMMANDBARCONTROL Private _This As Object ' Workaround for absence of This builtin function Private _Parent As Object Private _InternalIndex As Integer ' Index in toolbar including separators Private _Index As Integer ' Index in collection, starting at 1 !! Private _ControlType As Integer ' 1 of the msoControl* constants Private _ParentCommandBarName As String Private _ParentCommandBar As Object ' com.sun.star.ui.XUIElement Private _ParentBuiltin As Boolean Private _Element As Variant Private _BeginGroup As Boolean REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJCOMMANDBARCONTROL Set _This = Nothing Set _Parent = Nothing _Index = -1 _ParentCommandBarName = "" Set _ParentCommandBar = Nothing _ParentBuiltin = False _Element = Array() _BeginGroup = False End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() On Local Error Resume Next Call Class_Initialize() End Sub ' Destructor REM ----------------------------------------------------------------------------------------------------------------------- Public Sub Dispose() Call Class_Terminate() End Sub ' Explicit destructor REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS GET/LET/SET PROPERTIES --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Property Get BeginGroup() As Boolean BeginGroup = _PropertyGet("BeginGroup") End Property ' BeginGroup (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get BuiltIn() As Boolean BuiltIn = _PropertyGet("BuiltIn") End Property ' BuiltIn (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Caption() As Variant Caption = _PropertyGet("Caption") End Property ' Caption (get) Property Let Caption(ByVal pvValue As Variant) Call _PropertySet("Caption", pvValue) End Property ' Caption (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Index() As Integer Index = _PropertyGet("Index") End Property ' Index (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnAction() As Variant OnAction = _PropertyGet("OnAction") End Property ' OnAction (get) Property Let OnAction(ByVal pvValue As Variant) Call _PropertySet("OnAction", pvValue) End Property ' OnAction (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Parent() As Object Parent = _PropertyGet("Parent") End Property ' Parent (get) REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Exit_Function: Set Properties = vProperty Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Property Get TooltipText() As Variant TooltipText = _PropertyGet("TooltipText") End Property ' TooltipText (get) Property Let TooltipText(ByVal pvValue As Variant) Call _PropertySet("TooltipText", pvValue) End Property ' TooltipText (set) REM ----------------------------------------------------------------------------------------------------------------------- Public Function pType() As Integer pType = _PropertyGet("Type") End Function ' Type (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Visible() As Variant Visible = _PropertyGet("Visible") End Property ' Visible (get) Property Let Visible(ByVal pvValue As Variant) Call _PropertySet("Visible", pvValue) End Property ' Visible (set) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function Execute() ' Execute the command stored in a toolbar button If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "CommandBarControl.Execute" Utils._SetCalledSub(cstThisSub) Dim sExecute As String Execute = True sExecute = _GetPropertyValue(_Element, "CommandURL", "") Select Case True Case sExecute = "" : Execute = False Case _IsLeft(sExecute, ".uno:") Execute = DoCmd.RunCommand(sExecute) Case _IsLeft(sExecute, "vnd.sun.star.script:") Execute = Utils._RunScript(sExecute, Array(Nothing)) Case Else End Select Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Execute = False GoTo Exit_Function End Function ' Execute V1.3.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Utils._SetCalledSub("CommandBarControl.getProperty") If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub("CommandBar.getProperty") End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) Exit Function End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant _PropertiesList = Array("BeginGroup", "BuiltIn", "Caption", "Index" _ , "ObjectType", "OnAction", "Parent" _ , "TooltipText", "Type", "Visible" _ ) End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = "CommandBarControl.get" & psProperty Utils._SetCalledSub(cstThisSub) _PropertyGet = Null Dim oLayout As Object, iElementIndex As Integer Dim sValue As String Const cstUnoPrefix = ".uno:" Select Case UCase(psProperty) Case UCase("BeginGroup") _PropertyGet = _BeginGroup Case UCase("BuiltIn") sValue = _GetPropertyValue(_Element, "CommandURL", "") _PropertyGet = ( _IsLeft(sValue, cstUnoPrefix) ) Case UCase("Caption") _PropertyGet = _GetPropertyValue(_Element, "Label", "") Case UCase("Index") _PropertyGet = _Index Case UCase("ObjectType") _PropertyGet = _Type Case UCase("OnAction") _PropertyGet = _GetPropertyValue(_Element, "CommandURL", "") Case UCase("Parent") Set _PropertyGet = _Parent Case UCase("TooltipText") sValue = _GetPropertyValue(_Element, "Tooltip", "") If sValue <> "" Then _PropertyGet = sValue Else _PropertyGet = _GetPropertyValue(_Element, "Label", "") Case UCase("Type") _PropertyGet = msoControlButton Case UCase("Visible") _PropertyGet = _GetPropertyValue(_Element, "IsVisible", "") Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) _PropertyGet = Nothing GoTo Exit_Function End Function ' _PropertyGet REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean ' Return True if property setting OK If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = "CommandBarControl.set" & psProperty Utils._SetCalledSub(cstThisSub) _PropertySet = True Dim iArgNr As Integer Dim oSettings As Object, sValue As String Select Case UCase(_A2B_.CalledSub) Case UCase("setProperty") : iArgNr = 3 Case UCase("CommandBar.setProperty") : iArgNr = 2 Case UCase(cstThisSub) : iArgNr = 1 End Select If Not hasProperty(psProperty) Then Goto Trace_Error If _ParentBuiltin Then Goto Trace_Error ' Modifications of individual controls forbidden for builtin toolbars (design choice) Const cstUnoPrefix = ".uno:" Const cstScript = "vnd.sun.star.script:" Set oSettings = _ParentCommandBar.getSettings(True) Select Case UCase(psProperty) Case UCase("OnAction") If Not Utils._CheckArgument(pvValue, iArgNr, _AddNumeric(vbString), , False) Then Goto Trace_Error_Value Select Case VarType(pvValue) Case vbString If _IsLeft(pvValue, cstUnoPrefix) Then sValue = pvValue ElseIf _IsLeft(pvValue, cstScript) Then sValue = pvValue Else sValue = DoCmd.RunCommand(pvValue, True) End If Case Else ' Numeric sValue = DoCmd.RunCommand(pvValue, True) End Select _SetPropertyValue(_Element, "CommandURL", sValue) Case UCase("TooltipText") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value _SetPropertyValue(_Element, "Tooltip", pvValue) Case UCase("Visible") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value _SetPropertyValue(_Element, "IsVisible", pvValue) Case Else Goto Trace_Error End Select oSettings.replaceByIndex(_InternalIndex, _Element) _ParentCommandBar.setSettings(oSettings) Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet