Quelle  SF_PopupMenu.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="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)
 ' So far, vMenuItem is an Integer. Convert to the item name when relevant
 If Not ReturnId Then
  If vMenuItem > 0 Then vMenuItem = MenuIdentification.Item(CStr(vMenuItem)) Else vMenuItem = ""
 End If

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 UNO 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 Split()
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 case-sensitive comparison of keys)
 With ScriptForge.SF_Services
  Set MenuTree = .CreateScriptService("Dictionary", True)
  Set MenuIdentification = .CreateScriptService("Dictionary", True)
 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>