Quelle  CommandBarControl.xba   Sprache: unbekannt

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