| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801 |
- <?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="SF_PopupMenu" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
- REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
- REM === The SFWidgets library is one of the associated libraries. ===
- REM === Full documentation is available on https://help.libreoffice.org/ ===
- REM =======================================================================================================================
- Option Compatible
- Option ClassModule
- Option Explicit
- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
- ''' SF_PopupMenu
- ''' ============
- ''' Display a popup menu anywhere and any time
- '''
- ''' A popup menu is usually triggered by a mouse action (typically a right-click) on a dialog, a form
- ''' or one of their controls. In this case the menu will be displayed below the clicked area.
- ''' When triggered by other events, including in the normal flow of a user script, the script should
- ''' provide the coordinates of the topleft edge of the menu versus the actual component.
- '''
- ''' The menu is described from top to bottom. Each menu item receives a numeric and a string identifier.
- ''' The Execute() method returns the item selected by the user.
- '''
- ''' Menu items are either:
- ''' - usual items
- ''' - checkboxes
- ''' - radio buttons
- ''' - a menu separator
- ''' Menu items can be decorated with icons and tooltips.
- '''
- ''' Definitions:
- ''' SubmenuCharacter: the character or the character string that identifies how menus are cascading
- ''' Default = ">"
- ''' Can be set when invoking the PopupMenu service
- ''' ShortcutCharacter: the underline access key character
- ''' Default = "~"
- '''
- ''' Service invocation:
- ''' Sub OpenMenu(Optional poMouseEvent As Object)
- ''' Dim myMenu As Object
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent, , , ">>") ' Usual case
- ''' ' or
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", , X, Y, " | ") ' Use X and Y coordinates to place the menu
- '''
- ''' Menus and submenus
- ''' To create a popup menu with submenus, use the character defined in the
- ''' SubmenuCharacter property while creating the menu entry to define where it will be
- ''' placed. For instance, consider the following menu/submenu hierarchy.
- ''' Item A
- ''' Item B > Item B.1
- ''' Item B.2
- ''' ------ (line separator)
- ''' Item C > Item C.1 > Item C.1.1
- ''' Item C.1.2
- ''' Item C > Item C.2 > Item C.2.1
- ''' Item C.2.2
- ''' Next code will create the menu/submenu hierarchy
- ''' With myMenu
- ''' .AddItem("Item A")
- ''' .AddItem("Item B>Item B.1")
- ''' .AddItem("Item B>Item B.2")
- ''' .AddItem("---")
- ''' .AddItem("Item C>Item C.1>Item C.1.1")
- ''' .AddItem("Item C>Item C.1>Item C.1.2")
- ''' .AddItem("Item C>Item C.2>Item C.2.1")
- ''' .AddItem("Item C>Item C.2>Item C.2.2")
- ''' End With
- '''
- ''' Example 1: simulate a subset of the View menu in the menubar of the Basic IDE
- ''' Sub OpenMenu(Optional poMouseEvent As Object)
- ''' Dim myMenu As Object, vChoice As Variant
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent)
- ''' With myMenu
- ''' .AddCheckBox("View>Toolbars>Dialog")
- ''' .AddCheckBox("View>Toolbars>Find", Status := True)
- ''' .AddCheckBox("View>Status Bar", Status := True)
- ''' .AddItem("View>Full Screen", Name := "FULLSCREEN")
- ''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog"
- ''' ' When last item is clicked, return "FULLSCREEN"
- ''' .Dispose()
- ''' End With
- '''
- ''' Example 2: jump to another sheet of a Calc document
- ''' ' Link next Sub to the "Mouse button released" event of a form control of a Calc sheet
- ''' Sub JumpToSheet(Optional poEvent As Object)
- ''' Dim myMenu As Object, sChoice As String, myDoc As Object, vSheets As Variant, sSheet As String
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent)
- ''' Set myDoc = CreateScriptService("Calc", ThisComponent)
- ''' vSheets = myDoc.Sheets
- ''' For Each sSheet In vSheets
- ''' myMenu.AddItem(sSheet)
- ''' Next sSheet
- ''' sChoice = myMenu.Execute(False) ' Return sheet name, not sheet index
- ''' If sChoice <> "" Then myDoc.Activate(sChoice)
- ''' myDoc.Dispose()
- ''' myMenu.Dispose()
- ''' End Sub
- '''
- '''
- ''' Detailed user documentation:
- ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_popupmenu.html?DbPAR=BASIC
- '''
- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
- REM ================================================================== EXCEPTIONS
- REM ============================================================= PRIVATE MEMBERS
- Private [Me] As Object
- Private ObjectType As String ' Must be POPUPMENU
- Private ServiceName As String
- ' Menu descriptors
- Private MenuTree As Variant ' Dictionary treename - XPopupMenu pair
- Private MenuIdentification As Variant ' Dictionary item ID - item name
- Private SubmenuChar As String ' Delimiter in menu trees
- Private MenuRoot As Object ' stardiv.vcl.PopupMenu or com.sun.star.awt.XPopupMenu
- Private LastItem As Integer ' Every item has its entry number. This is the last one
- Private Rectangle As Object ' com.sun.star.awt.Rectangle
- Private PeerWindow As Object ' com.sun.star.awt.XWindowPeer
- Private MenubarMenu As Boolean ' When True, the actual popup menu depends on a menubar item
- REM ============================================================ MODULE CONSTANTS
- Private Const _UnderlineAccessKeyChar = "~"
- Private Const _DefaultSubmenuChar = ">"
- Private Const _SeparatorChar = "---"
- Private Const _IconsDirectory = "private:graphicrepository/" ' Refers to <install folder>/share/config/images_*.zip.
- Private Const cstUnoPrefix = ".uno:"
- Private Const cstNormal = "N"
- Private Const cstCheck = "C"
- Private Const cstRadio = "R"
- REM ====================================================== CONSTRUCTOR/DESTRUCTOR
- REM -----------------------------------------------------------------------------
- Private Sub Class_Initialize()
- Set [Me] = Nothing
- ObjectType = "POPUPMENU"
- ServiceName = "SFWidgets.PopupMenu"
- Set MenuTree = Nothing
- Set MenuIdentification = Nothing
- SubmenuChar = _DefaultSubmenuChar
- Set MenuRoot = Nothing
- LastItem = 0
- Set Rectangle = Nothing
- Set PeerWindow = Nothing
- MenubarMenu = False
- End Sub ' SFWidgets.SF_PopupMenu Constructor
- REM -----------------------------------------------------------------------------
- Private Sub Class_Terminate()
- Call Class_Initialize()
- End Sub ' SFWidgets.SF_PopupMenu Destructor
- REM -----------------------------------------------------------------------------
- Public Function Dispose() As Variant
- If Not IsNull(MenuTree) Then Set MenuTree = MenuTree.Dispose()
- If Not IsNull(MenuIdentification) Then Set MenuIdentification = MenuIdentification.Dispose()
- Call Class_Terminate()
- Set Dispose = Nothing
- End Function ' SFWidgets.SF_PopupMenu Explicit Destructor
- REM ================================================================== PROPERTIES
- REM -----------------------------------------------------------------------------
- Property Get ShortcutCharacter() As Variant
- ''' The ShortcutCharacter property specifies character preceding the underline access key
- ShortcutCharacter = _PropertyGet("ShortcutCharacter")
- End Property ' SFWidgets.SF_PopupMenu.ShortcutCharacter (get)
- REM -----------------------------------------------------------------------------
- Property Get SubmenuCharacter() As Variant
- ''' The SubmenuCharacter property specifies the character string indicating
- ''' a sub-menu in a popup menu item
- SubmenuCharacter = _PropertyGet("SubmenuCharacter")
- End Property ' SFWidgets.SF_PopupMenu.SubmenuCharacter (get)
- REM ===================================================================== METHODS
- REM -----------------------------------------------------------------------------
- Public Function AddCheckBox(Optional ByVal MenuItem As Variant _
- , Optional ByVal Name As Variant _
- , Optional ByVal Status As Variant _
- , Optional ByVal Icon As Variant _
- , Optional ByVal Tooltip As Variant _
- ) As Integer
- ''' Insert in the popup menu a new entry
- ''' Args:
- ''' MenuItem: The text to be displayed in the menu entry.
- ''' It determines also the hierarchy of the popup menu
- ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
- ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
- ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
- ''' Name: The name to be returned by the Execute() method if this item is clicked
- ''' Default = the last component of MenuItem
- ''' Status: when True the item is selected. Default = False
- ''' Icon: The path name of the icon to be displayed, without leading path separator
- ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
- ''' The exact file depends on the user options about the current icon set
- ''' Use the (normal) slash "/" as path separator
- ''' Example: "cmd/sc_cut.png"
- ''' Tooltip: The help text to be displayed as a tooltip
- ''' Returns:
- ''' The numeric identification of the newly inserted item
- ''' Examples:
- ''' Dim myMenu As Object, iId As Integer
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent)
- ''' iId = myMenu.AddCheckBox("Menu top>Checkbox item", Status := True)
- Dim iId As Integer ' Return value
- Const cstThisSub = "SFWidgets.PopupMenu.AddCheckBox"
- Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]"
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- iId = 0
- Check:
- If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
- If IsMissing(Status) Or IsEmpty(Status) Then Status = False
- If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
- If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
- If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch
- End If
- Try:
- iId = _AddItem(MenuItem, Name, cstCheck, Status, Icon, Tooltip)
- Finally:
- AddCheckBox = iId
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.AddCheckBox
- REM -----------------------------------------------------------------------------
- Public Function AddItem(Optional ByVal MenuItem As Variant _
- , Optional ByVal Name As Variant _
- , Optional ByVal Icon As Variant _
- , Optional ByVal Tooltip As Variant _
- ) As Integer
- ''' Insert in the popup menu a new entry
- ''' Args:
- ''' MenuItem: The text to be displayed in the menu entry.
- ''' It determines also the hierarchy of the popup menu
- ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
- ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
- ''' If the last component is equal to "---", a line separator is inserted and all other arguments are ignored
- ''' Name: The name to be returned by the Execute() method if this item is clicked
- ''' Default = the last component of MenuItem
- ''' Icon: The path name of the icon to be displayed, without leading path separator
- ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
- ''' The exact file depends on the user options about the current icon set
- ''' Use the (normal) slash "/" as path separator
- ''' Example: "cmd/sc_cut.png"
- ''' Tooltip: The help text to be displayed as a tooltip
- ''' Returns:
- ''' The numeric identification of the newly inserted item
- ''' Examples:
- ''' Dim myMenu As Object, iId As Integer
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent)
- ''' iId = myMenu.AddItem("Menu top>Normal item", Icon := "cmd.sc_cut.png")
- Dim iId As Integer ' Return value
- Const cstThisSub = "SFWidgets.PopupMenu.AddItem"
- Const cstSubArgs = "MenuItem, [Name=""""], [Icon=""""], [Tooltip=""""]"
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- iId = 0
- Check:
- If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
- If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
- If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
- If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch
- End If
- Try:
- iId = _AddItem(MenuItem, Name, cstNormal, False, Icon, Tooltip)
- Finally:
- AddItem = iId
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.AddItem
- REM -----------------------------------------------------------------------------
- Public Function AddRadioButton(Optional ByVal MenuItem As Variant _
- , Optional ByVal Name As Variant _
- , Optional ByVal Status As Variant _
- , Optional ByVal Icon As Variant _
- , Optional ByVal Tooltip As Variant _
- ) As Integer
- ''' Insert in the popup menu a new entry as a radio button
- ''' Args:
- ''' MenuItem: The text to be displayed in the menu entry.
- ''' It determines also the hieAddCheckBoxrarchy of the popup menu
- ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
- ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
- ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
- ''' Name: The name to be returned by the Execute() method if this item is clicked
- ''' Default = the last component of MenuItem
- ''' Status: when True the item is selected. Default = False
- ''' Icon: The path name of the icon to be displayed, without leading path separator
- ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
- ''' The exact file depends on the user options about the current icon set
- ''' Use the (normal) slash "/" as path separator
- ''' Example: "cmd/sc_cut.png"
- ''' Tooltip: The help text to be displayed as a tooltip
- ''' Returns:
- ''' The numeric identification of the newly inserted item
- ''' Examples:
- ''' Dim myMenu As Object, iId As Integer
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent)
- ''' iId = myMenu.AddRadioButton("Menu top>Radio item", Status := True)
- Dim iId As Integer ' Return value
- Const cstThisSub = "SFWidgets.PopupMenu.AddRadioButton"
- Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]"
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- iId = 0
- Check:
- If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
- If IsMissing(Status) Or IsEmpty(Status) Then Status = False
- If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
- If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
- If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch
- If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch
- End If
- Try:
- iId = _AddItem(MenuItem, Name, cstRadio, Status, Icon, Tooltip)
- Finally:
- AddRadioButton = iId
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.AddRadioButton
- REM -----------------------------------------------------------------------------
- Public Function Execute(Optional ByVal ReturnId As Variant) As Variant
- ''' Display the popup menu and return the menu item clicked by the user
- ''' Args:
- ''' ReturnId: When True (default), return the unique ID of the clicked item, otherwise return its name
- ''' Returns:
- ''' The numeric identification of clicked item or its name
- ''' The returned value is 0 or "" (depending on ReturnId) when the menu is cancelled
- ''' Examples:
- ''' Sub OpenMenu(Optional poMouseEvent As Object)
- ''' Dim myMenu As Object, vChoice As Variant
- ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent)
- ''' With myMenu
- ''' .AddCheckBox("View>Toolbars>Dialog")
- ''' .AddCheckBox("View>Toolbars>Find", STatus := True)
- ''' .AddCheckBox("View>Status Bar", STatus := True)
- ''' .AddItem("View>Full Screen", Name := "FULLSCREEN")
- ''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog"
- ''' ' When last item is clicked, return "FULLSCREEN"
- ''' End With
- Dim vMenuItem As Variant ' Return value
- Const cstThisSub = "SFWidgets.PopupMenu.Execute"
- Const cstSubArgs = "[ReturnId=True]"
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- vMenuItem = 0
- Check:
- If IsMissing(ReturnId) Or IsEmpty(ReturnId) Then ReturnId = True
- If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not ScriptForge.SF_Utils._Validate(ReturnId, "ReturnId", ScriptForge.V_BOOLEAN) Then GoTo Catch
- End If
- If Not ReturnId Then vMenuItem = ""
- Try:
- vMenuItem = MenuRoot.Execute(PeerWindow, Rectangle, com.sun.star.awt.PopupMenuDirection.EXECUTE_DEFAULT)
- If Not ReturnId Then vMenuItem = MenuIdentification.Item(CStr(vMenuItem))
- Finally:
- Execute = vMenuItem
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.Execute
- REM -----------------------------------------------------------------------------
- Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
- ''' Return the actual value of the given property
- ''' Args:
- ''' PropertyName: the name of the property as a string
- ''' Returns:
- ''' The actual value of the property
- ''' If the property does not exist, returns Null
- ''' Exceptions:
- ''' see the exceptions of the individual properties
- ''' Examples:
- ''' myModel.GetProperty("MyProperty")
- Const cstThisSub = "SFWidgets.PopupMenu.GetProperty"
- Const cstSubArgs = ""
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- GetProperty = Null
- Check:
- If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
- End If
- Try:
- GetProperty = _PropertyGet(PropertyName)
- Finally:
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.GetProperty
- REM -----------------------------------------------------------------------------
- Public Function Methods() As Variant
- ''' Return the list of public methods of the Model service as an array
- Methods = Array( _
- "AddCheckBox" _
- , "AddItem" _
- , "AddRadioButton" _
- , "Execute" _
- )
- End Function ' SFWidgets.SF_PopupMenu.Methods
- REM -----------------------------------------------------------------------------
- Public Function Properties() As Variant
- ''' Return the list or properties of the Timer a.AddItem("B>B1")class as an array
- Properties = Array( _
- "ShortcutCharacter" _
- , "SubmenuCharacter" _
- )
- End Function ' SFWidgets.SF_PopupMenu.Properties
- REM -----------------------------------------------------------------------------
- Public Function SetProperty(Optional ByVal PropertyName As Variant _
- , Optional ByRef Value As Variant _
- ) As Boolean
- ''' Set a new value to the given property
- ''' Args:
- ''' PropertyName: the name of the property as a string
- ''' Value: its new value
- ''' Exceptions
- ''' ARGUMENTERROR The property does not exist
- Const cstThisSub = "SFWidgets.PopupMenu.SetProperty"
- Const cstSubArgs = "PropertyName, Value"
- If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- SetProperty = False
- Check:
- If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
- If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
- End If
- Try:
- SetProperty = _PropertySet(PropertyName, Value)
- Finally:
- SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu.SetProperty
- REM =========================================================== PRIVATE FUNCTIONS
- REM -----------------------------------------------------------------------------
- Public Function _AddItem(ByVal MenuItem As String _
- , ByVal Name As String _
- , ByVal ItemType As String _
- , ByVal Status As Boolean _
- , ByVal Icon As String _
- , ByVal Tooltip As String _
- , Optional ByVal Command As String _
- ) As Integer
- ''' Insert in the popup menu a new entry
- ''' Args:
- ''' MenuItem: The text to be displayed in the menu entry.
- ''' It determines also the hierarchy of the popup menu
- ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
- ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
- ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
- ''' Name: The name to be returned by the Execute() method if this item is clicked
- ''' Default = the last component of MenuItem
- ''' ItemType: "N"(ormal, "C"(heck) or "R"(adio)
- ''' Status: when True the item is selected
- ''' Icon: The path name of the icon to be displayed, without leading path separator
- ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
- ''' The exact file depends on the user options about the current icon set
- ''' Use the (normal) slash "/" as path separator
- ''' Example: "cmd/sc_cut.png"
- ''' Tooltip: The help text to be displayed as a tooltip
- ''' Command: only for menubar menus
- ''' Either a uo command like ".uno:About"
- ''' or a script to be run: script URI ::: string argument to be passed to the script
- ''' Returns:
- ''' The numeric identification of the newly inserted item
- Dim iId As Integer ' Return value
- Dim vSplit As Variant ' Split menu item
- Dim sMenu As String ' Submenu where to attach the new item, as a string
- Dim oMenu As Object ' Submenu where to attach the new item, as an object
- Dim sName As String ' The text displayed in the menu box
- Dim oImage As Object ' com.sun.star.graphic.XGraphic
- Dim sCommand As String ' Alias of Command completed with arguments
- Const cstCommandSep = ","
- On Local Error GoTo Catch
- iId = 0
- If IsMissing(Command) Then Command = ""
- Try:
- ' Run through the upper menu tree
- vSplit = _SplitMenuItem(MenuItem)
- ' Create and determine the menu to which to attach the new item
- sMenu = vSplit(0)
- Set oMenu = _GetPopupMenu(sMenu) ' Run through the upper menu tree and retain the last branch
- ' Insert the new item
- LastItem = LastItem + 1
- sName = vSplit(1)
-
- With oMenu
- If sName = _SeparatorChar Then
- .insertSeparator(-1)
- Else
- Select Case ItemType
- Case cstNormal
- .insertItem(LastItem, sName, 0, -1)
- Case cstCheck
- .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.CHECKABLE + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1)
- .checkItem(LastItem, Status)
- Case cstRadio
- .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.RADIOCHECK + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1)
- .checkItem(LastItem, Status)
- End Select
- ' Store the ID - Name relation
- If Len(Name) = 0 Then Name = Replace(sName, _UnderlineAccessKeyChar, "")
- MenuIdentification.Add(CStr(LastItem), Name)
- ' Add the icon when relevant
- If Len(Icon) > 0 Then
- Set oImage = _GetImageFromUrl(_IconsDirectory & Icon)
- If Not IsNull(oImage) Then .setItemImage(LastItem, oImage, False)
- End If
- ' Add the tooltip when relevant
- If Len(Tooltip) > 0 Then .setTipHelpText(LastItem, Tooltip)
- ' Add the command: UNO command or script to run - menubar menus only
- If Len(Command) > 0 Then
- If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then
- sCommand = Command
- Else
- sCommand = Command & cstCommandSep & Name & cstCommandSep & CStr(LastItem)
- End If
- .setCommand(LastItem, sCommand)
- End If
- End If
- End With
- iId = LastItem
- Finally:
- _AddItem = iId
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu._AddItem
- REM -----------------------------------------------------------------------------
- Private Function _GetImageFromURL(ByVal psUrl as String) As Object
- ''' Returns a com.sun.star.graphic.XGraphic instance based on the given URL
- ''' The returned object is intended to be inserted as an icon in the popup menu
- ''' Derived from "Useful Macro Information For OpenOffice" By Andrew Pitonyak
- Dim vMediaProperties As Variant ' Array of com.sun.star.beans.PropertyValue
- Dim oGraphicProvider As Object ' com.sun.star.graphic.GraphicProvider
- Dim oImage As Object ' Return value
- On Local Error GoTo Catch ' Ignore errors
- Set oImage = Nothing
- Try:
- ' Create graphic provider instance to load images from files.
- Set oGraphicProvider = CreateUnoService("com.sun.star.graphic.GraphicProvider")
- ' Set the URL property so graphic provider is able to load the image
- Set vMediaProperties = Array(ScriptForge.SF_Utils._MakePropertyValue("URL", psURL))
- ' Retrieve the com.sun.star.graphic.XGraphic instance
- Set oImage = oGraphicProvider.queryGraphic(vMediaProperties)
- Finally:
- Set _GetImageFromUrl = oImage
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu._GetImageFromUrl
- REM -----------------------------------------------------------------------------
- Private Function _GetPopupMenu(ByVal psSubmenu As String) As Object
- ''' Get the com.sun.star.awt.XPopupMenu object corresponding with the string in argument
- ''' If the menu exists, it is found in the MenuTree dictionary
- ''' If it does not exist, it is created recursively.
- ''' Args:
- ''' psSubmenu: a string like "A>B"
- ''' Returns
- ''' A com.sun.star.awt.XpopupMenu object
- ''' Example
- ''' If psSubmenu = "A>B>C>D", and only the root menu exists,
- ''' - "A", "A>B", "A>B>C", "A>B>C>D" should be created
- ''' - the popup menu corresponding with "A>B>C>D" should be returned
- Dim oPopup As Object ' Return value
- Dim vSplit As Variant ' An array as returned by _SplitMenuItem()
- Dim sMenu As String ' The left part of psSubmenu
- Dim oMenu As Object ' com.sun.star.awt.XpopupMenu
- Dim oLastMenu As Object ' com.sun.star.awt.XpopupMenu
- Dim i As Long
- Set oPopup = Nothing
- Set oLastMenu = MenuRoot
- Try:
- If Len(psSubmenu) = 0 Then ' Menu starts at the root
- Set oPopup = MenuRoot
- ElseIf MenuTree.Exists(psSubmenu) Then ' Shortcut: if the submenu exists, get it directly
- Set oPopup = MenuTree.Item(psSubmenu)
- Else ' Build the tree
- vSplit = Split(psSubmenu, SubmenuChar)
- ' Search the successive submenus in the MenuTree dictionary, If not found, create a new entry
- For i = 0 To UBound(vSplit)
- sMenu = Join(ScriptForge.SF_Array.Slice(vSplit, 0, i), SubmenuChar)
- If MenuTree.Exists(sMenu) Then
- Set oLastMenu = MenuTree.Item(sMenu)
- Else
- ' Insert the new menu tree item
- LastItem = LastItem + 1
- oLastMenu.insertItem(LastItem, vSplit(i), 0, -1)
- Set oMenu = CreateUnoService("stardiv.vcl.PopupMenu")
- If MenubarMenu Then SFWidgets.SF_MenuListener.SetMenuListener(oMenu)
- MenuTree.Add(sMenu, oMenu)
- oLastMenu.setPopupMenu(LastItem, oMenu)
- Set oLastMenu = oMenu
- End If
- Next i
- Set oPopup = oLastMenu
- End If
- Finally:
- Set _GetPopupMenu = oPopup
- Exit Function
- End Function ' SFWidgets.SF_PopupMenu._GetPopupMenu
- REM -----------------------------------------------------------------------------
- Public Sub _Initialize(ByRef poPeer As Object _
- , plXPos As Long _
- , plYPos As Long _
- , psSubmenuChar As String _
- )
- ''' Complete the object creation process:
- ''' - Initialize the dictionaries
- ''' - initialize the root popup menu
- ''' - initialize the display area
- ''' - store the arguments for later use
- ''' Args:
- ''' poPeer: a peer window
- ''' plXPos, plYPos: the coordinates
- Try:
- ' Initialize the dictionaries
- With ScriptForge.SF_Services
- Set MenuTree = .CreateScriptService("Dictionary")
- Set MenuIdentification = .CreateScriptService("Dictionary")
- End With
- ' Initialize the root of the menu tree
- Set MenuRoot = CreateUnoService("stardiv.vcl.PopupMenu")
- ' Setup the display area
- Set Rectangle = New com.sun.star.awt.Rectangle
- Rectangle.X = plXPos
- Rectangle.Y = plYPos
- ' Keep the targeted window
- Set PeerWindow = poPeer
- ' Store the submenu character
- If Len(psSubmenuChar) > 0 Then SubmenuChar = psSubmenuChar
- Finally:
- Exit Sub
- End Sub ' SFWidgets.SF_PopupMenu._Initialize
- REM -----------------------------------------------------------------------------
- Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
- ''' Return the value of the named property
- ''' Args:
- ''' psProperty: the name of the property
- Dim vGet As Variant ' Return value
- Dim cstThisSub As String
- Const cstSubArgs = ""
- cstThisSub = "SFWidgets.PopupMenu.get" & psProperty
- If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
- ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
- _PropertyGet = Null
- Select Case UCase(psProperty)
- Case UCase("ShortcutCharacter")
- _PropertyGet = _UnderlineAccessKeyChar
- Case UCase("SubmenuCharacter")
- _PropertyGet = SubmenuChar
- Case Else
- _PropertyGet = Null
- End Select
- Finally:
- ScriptForge.SF_Utils._ExitFunction(cstThisSub)
- Exit Function
- Catch:
- GoTo Finally
- End Function ' SFWidgets.SF_PopupMenu._PropertyGet
- REM -----------------------------------------------------------------------------
- Private Function _Repr() As String
- ''' Convert the SF_PopupMenu instance to a readable string, typically for debugging purposes (DebugPrint ...)
- ''' Args:
- ''' Return:
- ''' "[PopupMenu]: Name, Type (dialogname)
- _Repr = "[PopupMenu]: " & SF_String.Represent(MenuTree.Keys()) & ", " & SF_String.Represent(MenuIdentification.Items())
- End Function ' SFWidgets.SF_PopupMenu._Repr
- REM -----------------------------------------------------------------------------
- Private Function _SplitMenuItem(ByVal psMenuItem As String ) As Variant
- ''' Split a menu item given as a string and delimited by the submenu character
- ''' Args:
- ''' psMenuItem: a string like "A>B>C"
- ''' Returns:
- ''' An array: [0] = "A>B"
- ''' [1] = "C"
- Dim vReturn(0 To 1) As String ' Return value
- Dim vMenus() As Variant ' Array of menus
- Try:
- vMenus = Split(psMenuItem, SubmenuChar)
- vReturn(1) = vMenus(UBound(vMenus))
- vReturn(0) = Left(psMenuItem, Len(psMenuItem) - Iif(UBound(vMenus) > 0, Len(SubmenuChar), 0) - Len(vReturn(1)))
- Finally:
- _SplitMenuItem = vReturn
- End Function ' SFWidgets.SF_PopupMenu._SplitMenuItem
- REM ============================================ END OF SFWIDGETS.SF_POPUPMENU
- </script:module>
|
