diff options
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/CommandBarControl.xba | 339 |
1 files changed, 339 insertions, 0 deletions
diff --git a/wizards/source/access2base/CommandBarControl.xba b/wizards/source/access2base/CommandBarControl.xba new file mode 100644 index 000000000..9cf183ba9 --- /dev/null +++ b/wizards/source/access2base/CommandBarControl.xba @@ -0,0 +1,339 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="CommandBarControl" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option 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 + +</script:module>
\ No newline at end of file |