<?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>