| blob | 3d5ba65a80f8f486919810a8c4629ca83ec67142 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_PopupMenu" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === The SFWidgets library is one of the associated libraries. ===
6 REM === Full documentation is available on https://help.libreoffice.org/ ===
7 REM =======================================================================================================================
9 Option Compatible
10 Option ClassModule
12 Option Explicit
14 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
15 ''' SF_PopupMenu
16 ''' ============
17 ''' Display a popup menu anywhere and any time
18 '''
19 ''' A popup menu is usually triggered by a mouse action (typically a right-click) on a dialog, a form
20 ''' or one of their controls. In this case the menu will be displayed below the clicked area.
21 ''' When triggered by other events, including in the normal flow of a user script, the script should
22 ''' provide the coordinates of the topleft edge of the menu versus the actual component.
23 '''
24 ''' The menu is described from top to bottom. Each menu item receives a numeric and a string identifier.
25 ''' The Execute() method returns the item selected by the user.
26 '''
27 ''' Menu items are either:
28 ''' - usual items
29 ''' - checkboxes
30 ''' - radio buttons
31 ''' - a menu separator
32 ''' Menu items can be decorated with icons and tooltips.
33 '''
34 ''' Definitions:
35 ''' SubmenuCharacter: the character or the character string that identifies how menus are cascading
37 ''' Can be set when invoking the PopupMenu service
38 ''' ShortcutCharacter: the underline access key character
40 '''
41 ''' Service invocation:
42 ''' Sub OpenMenu(Optional poMouseEvent As Object)
43 ''' Dim myMenu As Object
44 ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent, , , ">>") ' Usual case
45 ''' ' or
46 ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", , X, Y, " | ") ' Use X and Y coordinates to place the menu
47 '''
48 ''' Menus and submenus
49 ''' To create a popup menu with submenus, use the character defined in the
50 ''' SubmenuCharacter property while creating the menu entry to define where it will be
51 ''' placed. For instance, consider the following menu/submenu hierarchy.
52 ''' Item A
55 ''' ------ (line separator)
60 ''' Next code will create the menu/submenu hierarchy
61 ''' With myMenu
70 ''' End With
71 '''
73 ''' Sub OpenMenu(Optional poMouseEvent As Object)
74 ''' Dim myMenu As Object, vChoice As Variant
75 ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent)
76 ''' With myMenu
81 ''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog"
83 ''' .Dispose()
84 ''' End With
85 '''
87 ''' ' Link next Sub to the "Mouse button released" event of a form control of a Calc sheet
88 ''' Sub JumpToSheet(Optional poEvent As Object)
89 ''' Dim myMenu As Object, sChoice As String, myDoc As Object, vSheets As Variant, sSheet As String
92 ''' vSheets = myDoc.Sheets
93 ''' For Each sSheet In vSheets
94 ''' myMenu.AddItem(sSheet)
95 ''' Next sSheet
98 ''' myDoc.Dispose()
99 ''' myMenu.Dispose()
100 ''' End Sub
101 '''
102 '''
103 ''' Detailed user documentation:
104 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_popupmenu.html?DbPAR=BASIC
105 '''
106 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
108 REM ================================================================== EXCEPTIONS
110 REM ============================================================= PRIVATE MEMBERS
112 Private [Me] As Object
113 Private ObjectType As String ' Must be POPUPMENU
114 Private ServiceName As String
117 ' Menu descriptors
118 Private MenuTree As Variant ' Dictionary treename - XPopupMenu pair
119 Private MenuIdentification As Variant ' Dictionary item ID - item name
120 Private SubmenuChar As String ' Delimiter in menu trees
121 Private MenuRoot As Object ' stardiv.vcl.PopupMenu or com.sun.star.awt.XPopupMenu
122 Private LastItem As Integer ' Every item has its entry number. This is the last one
123 Private Rectangle As Object ' com.sun.star.awt.Rectangle
124 Private PeerWindow As Object ' com.sun.star.awt.XWindowPeer
125 Private MenubarMenu As Boolean ' When True, the actual popup menu depends on a menubar item
127 REM ============================================================ MODULE CONSTANTS
130 Private Const _DefaultSubmenuChar = ">"
132 Private Const _IconsDirectory = "private:graphicrepository/" ' Refers to <install folder>/share/config/images_*.zip.
138 REM ====================================================== CONSTRUCTOR/DESTRUCTOR
140 REM -----------------------------------------------------------------------------
141 Private Sub Class_Initialize()
142 Set [Me] = Nothing
145 Set MenuTree = Nothing
146 Set MenuIdentification = Nothing
147 SubmenuChar = _DefaultSubmenuChar
148 Set MenuRoot = Nothing
149 LastItem = 0
150 Set Rectangle = Nothing
151 Set PeerWindow = Nothing
152 MenubarMenu = False
153 End Sub ' SFWidgets.SF_PopupMenu Constructor
155 REM -----------------------------------------------------------------------------
156 Private Sub Class_Terminate()
157 Call Class_Initialize()
158 End Sub ' SFWidgets.SF_PopupMenu Destructor
160 REM -----------------------------------------------------------------------------
161 Public Function Dispose() As Variant
162 If Not IsNull(MenuTree) Then Set MenuTree = MenuTree.Dispose()
163 If Not IsNull(MenuIdentification) Then Set MenuIdentification = MenuIdentification.Dispose()
164 Call Class_Terminate()
165 Set Dispose = Nothing
166 End Function ' SFWidgets.SF_PopupMenu Explicit Destructor
168 REM ================================================================== PROPERTIES
170 REM -----------------------------------------------------------------------------
171 Property Get ShortcutCharacter() As Variant
172 ''' The ShortcutCharacter property specifies character preceding the underline access key
174 End Property ' SFWidgets.SF_PopupMenu.ShortcutCharacter (get)
176 REM -----------------------------------------------------------------------------
177 Property Get SubmenuCharacter() As Variant
178 ''' The SubmenuCharacter property specifies the character string indicating
179 ''' a sub-menu in a popup menu item
181 End Property ' SFWidgets.SF_PopupMenu.SubmenuCharacter (get)
183 REM ===================================================================== METHODS
185 REM -----------------------------------------------------------------------------
186 Public Function AddCheckBox(Optional ByVal MenuItem As Variant _
187 , Optional ByVal Name As Variant _
188 , Optional ByVal Status As Variant _
189 , Optional ByVal Icon As Variant _
190 , Optional ByVal Tooltip As Variant _
191 ) As Integer
192 ''' Insert in the popup menu a new entry
193 ''' Args:
194 ''' MenuItem: The text to be displayed in the menu entry.
195 ''' It determines also the hierarchy of the popup menu
196 ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
197 ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
198 ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
199 ''' Name: The name to be returned by the Execute() method if this item is clicked
200 ''' Default = the last component of MenuItem
201 ''' Status: when True the item is selected. Default = False
202 ''' Icon: The path name of the icon to be displayed, without leading path separator
203 ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
204 ''' The exact file depends on the user options about the current icon set
207 ''' Tooltip: The help text to be displayed as a tooltip
208 ''' Returns:
209 ''' The numeric identification of the newly inserted item
210 ''' Examples:
211 ''' Dim myMenu As Object, iId As Integer
213 ''' iId = myMenu.AddCheckBox("Menu top>Checkbox item", Status := True)
215 Dim iId As Integer ' Return value
218 Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]"
220 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
221 iId = 0
223 Check:
224 If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
225 If IsMissing(Status) Or IsEmpty(Status) Then Status = False
226 If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
227 If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
228 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
231 If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch
234 End If
236 Try:
237 iId = _AddItem(MenuItem, Name, cstCheck, Status, Icon, Tooltip)
239 Finally:
240 AddCheckBox = iId
241 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
242 Exit Function
243 Catch:
244 GoTo Finally
245 End Function ' SFWidgets.SF_PopupMenu.AddCheckBox
247 REM -----------------------------------------------------------------------------
248 Public Function AddItem(Optional ByVal MenuItem As Variant _
249 , Optional ByVal Name As Variant _
250 , Optional ByVal Icon As Variant _
251 , Optional ByVal Tooltip As Variant _
252 ) As Integer
253 ''' Insert in the popup menu a new entry
254 ''' Args:
255 ''' MenuItem: The text to be displayed in the menu entry.
256 ''' It determines also the hierarchy of the popup menu
257 ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
258 ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
259 ''' If the last component is equal to "---", a line separator is inserted and all other arguments are ignored
260 ''' Name: The name to be returned by the Execute() method if this item is clicked
261 ''' Default = the last component of MenuItem
262 ''' Icon: The path name of the icon to be displayed, without leading path separator
263 ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
264 ''' The exact file depends on the user options about the current icon set
267 ''' Tooltip: The help text to be displayed as a tooltip
268 ''' Returns:
269 ''' The numeric identification of the newly inserted item
270 ''' Examples:
271 ''' Dim myMenu As Object, iId As Integer
273 ''' iId = myMenu.AddItem("Menu top>Normal item", Icon := "cmd.sc_cut.png")
275 Dim iId As Integer ' Return value
278 Const cstSubArgs = "MenuItem, [Name=""""], [Icon=""""], [Tooltip=""""]"
280 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
281 iId = 0
283 Check:
284 If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
285 If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
286 If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
287 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
292 End If
294 Try:
295 iId = _AddItem(MenuItem, Name, cstNormal, False, Icon, Tooltip)
297 Finally:
298 AddItem = iId
299 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
300 Exit Function
301 Catch:
302 GoTo Finally
303 End Function ' SFWidgets.SF_PopupMenu.AddItem
305 REM -----------------------------------------------------------------------------
306 Public Function AddRadioButton(Optional ByVal MenuItem As Variant _
307 , Optional ByVal Name As Variant _
308 , Optional ByVal Status As Variant _
309 , Optional ByVal Icon As Variant _
310 , Optional ByVal Tooltip As Variant _
311 ) As Integer
312 ''' Insert in the popup menu a new entry as a radio button
313 ''' Args:
314 ''' MenuItem: The text to be displayed in the menu entry.
315 ''' It determines also the hieAddCheckBoxrarchy of the popup menu
316 ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
317 ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
318 ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
319 ''' Name: The name to be returned by the Execute() method if this item is clicked
320 ''' Default = the last component of MenuItem
321 ''' Status: when True the item is selected. Default = False
322 ''' Icon: The path name of the icon to be displayed, without leading path separator
323 ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
324 ''' The exact file depends on the user options about the current icon set
327 ''' Tooltip: The help text to be displayed as a tooltip
328 ''' Returns:
329 ''' The numeric identification of the newly inserted item
330 ''' Examples:
331 ''' Dim myMenu As Object, iId As Integer
333 ''' iId = myMenu.AddRadioButton("Menu top>Radio item", Status := True)
335 Dim iId As Integer ' Return value
338 Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]"
340 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
341 iId = 0
343 Check:
344 If IsMissing(Name) Or IsEmpty(Name) Then Name = ""
345 If IsMissing(Status) Or IsEmpty(Status) Then Status = False
346 If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = ""
347 If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = ""
348 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
351 If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch
354 End If
356 Try:
357 iId = _AddItem(MenuItem, Name, cstRadio, Status, Icon, Tooltip)
359 Finally:
360 AddRadioButton = iId
361 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
362 Exit Function
363 Catch:
364 GoTo Finally
365 End Function ' SFWidgets.SF_PopupMenu.AddRadioButton
367 REM -----------------------------------------------------------------------------
368 Public Function Execute(Optional ByVal ReturnId As Variant) As Variant
369 ''' Display the popup menu and return the menu item clicked by the user
370 ''' Args:
371 ''' ReturnId: When True (default), return the unique ID of the clicked item, otherwise return its name
372 ''' Returns:
373 ''' The numeric identification of clicked item or its name
374 ''' The returned value is 0 or "" (depending on ReturnId) when the menu is cancelled
375 ''' Examples:
376 ''' Sub OpenMenu(Optional poMouseEvent As Object)
377 ''' Dim myMenu As Object, vChoice As Variant
378 ''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent)
379 ''' With myMenu
384 ''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog"
386 ''' End With
388 Dim vMenuItem As Variant ' Return value
393 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
394 vMenuItem = 0
396 Check:
397 If IsMissing(ReturnId) Or IsEmpty(ReturnId) Then ReturnId = True
398 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
399 If Not ScriptForge.SF_Utils._Validate(ReturnId, "ReturnId", ScriptForge.V_BOOLEAN) Then GoTo Catch
400 End If
401 If Not ReturnId Then vMenuItem = ""
403 Try:
404 vMenuItem = MenuRoot.Execute(PeerWindow, Rectangle, com.sun.star.awt.PopupMenuDirection.EXECUTE_DEFAULT)
405 If Not ReturnId Then vMenuItem = MenuIdentification.Item(CStr(vMenuItem))
407 Finally:
408 Execute = vMenuItem
409 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
410 Exit Function
411 Catch:
412 GoTo Finally
413 End Function ' SFWidgets.SF_PopupMenu.Execute
415 REM -----------------------------------------------------------------------------
416 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
417 ''' Return the actual value of the given property
418 ''' Args:
419 ''' PropertyName: the name of the property as a string
420 ''' Returns:
421 ''' The actual value of the property
422 ''' If the property does not exist, returns Null
423 ''' Exceptions:
424 ''' see the exceptions of the individual properties
425 ''' Examples:
429 Const cstSubArgs = ""
431 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
432 GetProperty = Null
434 Check:
435 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
436 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
437 End If
439 Try:
440 GetProperty = _PropertyGet(PropertyName)
442 Finally:
443 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
444 Exit Function
445 Catch:
446 GoTo Finally
447 End Function ' SFWidgets.SF_PopupMenu.GetProperty
449 REM -----------------------------------------------------------------------------
450 Public Function Methods() As Variant
451 ''' Return the list of public methods of the Model service as an array
453 Methods = Array( _
458 )
460 End Function ' SFWidgets.SF_PopupMenu.Methods
462 REM -----------------------------------------------------------------------------
463 Public Function Properties() As Variant
464 ''' Return the list or properties of the Timer a.AddItem("B>B1")class as an array
466 Properties = Array( _
469 )
471 End Function ' SFWidgets.SF_PopupMenu.Properties
473 REM -----------------------------------------------------------------------------
474 Public Function SetProperty(Optional ByVal PropertyName As Variant _
475 , Optional ByRef Value As Variant _
476 ) As Boolean
477 ''' Set a new value to the given property
478 ''' Args:
479 ''' PropertyName: the name of the property as a string
480 ''' Value: its new value
481 ''' Exceptions
482 ''' ARGUMENTERROR The property does not exist
487 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
488 SetProperty = False
490 Check:
491 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
492 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
493 End If
495 Try:
496 SetProperty = _PropertySet(PropertyName, Value)
498 Finally:
499 SF_Utils._ExitFunction(cstThisSub)
500 Exit Function
501 Catch:
502 GoTo Finally
503 End Function ' SFWidgets.SF_PopupMenu.SetProperty
505 REM =========================================================== PRIVATE FUNCTIONS
507 REM -----------------------------------------------------------------------------
508 Public Function _AddItem(ByVal MenuItem As String _
509 , ByVal Name As String _
510 , ByVal ItemType As String _
511 , ByVal Status As Boolean _
512 , ByVal Icon As String _
513 , ByVal Tooltip As String _
514 , Optional ByVal Command As String _
515 ) As Integer
516 ''' Insert in the popup menu a new entry
517 ''' Args:
518 ''' MenuItem: The text to be displayed in the menu entry.
519 ''' It determines also the hierarchy of the popup menu
520 ''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch
521 ''' Example: A>B>C means "C" is a new entry in submenu "A => B =>"
522 ''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted
523 ''' Name: The name to be returned by the Execute() method if this item is clicked
524 ''' Default = the last component of MenuItem
526 ''' Status: when True the item is selected
527 ''' Icon: The path name of the icon to be displayed, without leading path separator
528 ''' The icons are stored in one of the <install folder>/share/config/images_*.zip files
529 ''' The exact file depends on the user options about the current icon set
532 ''' Tooltip: The help text to be displayed as a tooltip
533 ''' Command: only for menubar menus
535 ''' or a script to be run: script URI ::: string argument to be passed to the script
536 ''' Returns:
537 ''' The numeric identification of the newly inserted item
539 Dim iId As Integer ' Return value
540 Dim vSplit As Variant ' Split menu item
541 Dim sMenu As String ' Submenu where to attach the new item, as a string
542 Dim oMenu As Object ' Submenu where to attach the new item, as an object
543 Dim sName As String ' The text displayed in the menu box
544 Dim oImage As Object ' com.sun.star.graphic.XGraphic
545 Dim sCommand As String ' Alias of Command completed with arguments
548 On Local Error GoTo Catch
549 iId = 0
550 If IsMissing(Command) Then Command = ""
552 Try:
553 ' Run through the upper menu tree
554 vSplit = _SplitMenuItem(MenuItem)
556 ' Create and determine the menu to which to attach the new item
557 sMenu = vSplit(0)
558 Set oMenu = _GetPopupMenu(sMenu) ' Run through the upper menu tree and retain the last branch
560 ' Insert the new item
561 LastItem = LastItem + 1
562 sName = vSplit(1)
564 With oMenu
565 If sName = _SeparatorChar Then
566 .insertSeparator(-1)
567 Else
568 Select Case ItemType
569 Case cstNormal
571 Case cstCheck
572 .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.CHECKABLE + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1)
573 .checkItem(LastItem, Status)
574 Case cstRadio
575 .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.RADIOCHECK + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1)
576 .checkItem(LastItem, Status)
577 End Select
579 ' Store the ID - Name relation
581 MenuIdentification.Add(CStr(LastItem), Name)
583 ' Add the icon when relevant
585 Set oImage = _GetImageFromUrl(_IconsDirectory & Icon)
586 If Not IsNull(oImage) Then .setItemImage(LastItem, oImage, False)
587 End If
589 ' Add the tooltip when relevant
592 ' Add the command: UNO command or script to run - menubar menus only
594 If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then
595 sCommand = Command
596 Else
598 End If
599 .setCommand(LastItem, sCommand)
600 End If
601 End If
602 End With
604 iId = LastItem
606 Finally:
607 _AddItem = iId
608 Exit Function
609 Catch:
610 GoTo Finally
611 End Function ' SFWidgets.SF_PopupMenu._AddItem
613 REM -----------------------------------------------------------------------------
614 Private Function _GetImageFromURL(ByVal psUrl as String) As Object
615 ''' Returns a com.sun.star.graphic.XGraphic instance based on the given URL
616 ''' The returned object is intended to be inserted as an icon in the popup menu
617 ''' Derived from "Useful Macro Information For OpenOffice" By Andrew Pitonyak
619 Dim vMediaProperties As Variant ' Array of com.sun.star.beans.PropertyValue
620 Dim oGraphicProvider As Object ' com.sun.star.graphic.GraphicProvider
621 Dim oImage As Object ' Return value
623 On Local Error GoTo Catch ' Ignore errors
624 Set oImage = Nothing
626 Try:
627 ' Create graphic provider instance to load images from files.
630 ' Set the URL property so graphic provider is able to load the image
633 ' Retrieve the com.sun.star.graphic.XGraphic instance
634 Set oImage = oGraphicProvider.queryGraphic(vMediaProperties)
636 Finally:
637 Set _GetImageFromUrl = oImage
638 Exit Function
639 Catch:
640 GoTo Finally
641 End Function ' SFWidgets.SF_PopupMenu._GetImageFromUrl
643 REM -----------------------------------------------------------------------------
644 Private Function _GetPopupMenu(ByVal psSubmenu As String) As Object
645 ''' Get the com.sun.star.awt.XPopupMenu object corresponding with the string in argument
646 ''' If the menu exists, it is found in the MenuTree dictionary
647 ''' If it does not exist, it is created recursively.
648 ''' Args:
650 ''' Returns
651 ''' A com.sun.star.awt.XpopupMenu object
652 ''' Example
654 ''' - "A", "A>B", "A>B>C", "A>B>C>D" should be created
655 ''' - the popup menu corresponding with "A>B>C>D" should be returned
657 Dim oPopup As Object ' Return value
658 Dim vSplit As Variant ' An array as returned by _SplitMenuItem()
659 Dim sMenu As String ' The left part of psSubmenu
660 Dim oMenu As Object ' com.sun.star.awt.XpopupMenu
661 Dim oLastMenu As Object ' com.sun.star.awt.XpopupMenu
662 Dim i As Long
664 Set oPopup = Nothing
665 Set oLastMenu = MenuRoot
666 Try:
668 Set oPopup = MenuRoot
669 ElseIf MenuTree.Exists(psSubmenu) Then ' Shortcut: if the submenu exists, get it directly
670 Set oPopup = MenuTree.Item(psSubmenu)
671 Else ' Build the tree
672 vSplit = Split(psSubmenu, SubmenuChar)
673 ' Search the successive submenus in the MenuTree dictionary, If not found, create a new entry
674 For i = 0 To UBound(vSplit)
675 sMenu = Join(ScriptForge.SF_Array.Slice(vSplit, 0, i), SubmenuChar)
676 If MenuTree.Exists(sMenu) Then
677 Set oLastMenu = MenuTree.Item(sMenu)
678 Else
679 ' Insert the new menu tree item
680 LastItem = LastItem + 1
683 If MenubarMenu Then SFWidgets.SF_MenuListener.SetMenuListener(oMenu)
684 MenuTree.Add(sMenu, oMenu)
685 oLastMenu.setPopupMenu(LastItem, oMenu)
686 Set oLastMenu = oMenu
687 End If
688 Next i
689 Set oPopup = oLastMenu
690 End If
692 Finally:
693 Set _GetPopupMenu = oPopup
694 Exit Function
695 End Function ' SFWidgets.SF_PopupMenu._GetPopupMenu
697 REM -----------------------------------------------------------------------------
698 Public Sub _Initialize(ByRef poPeer As Object _
699 , plXPos As Long _
700 , plYPos As Long _
701 , psSubmenuChar As String _
702 )
703 ''' Complete the object creation process:
704 ''' - Initialize the dictionaries
705 ''' - initialize the root popup menu
706 ''' - initialize the display area
707 ''' - store the arguments for later use
708 ''' Args:
709 ''' poPeer: a peer window
710 ''' plXPos, plYPos: the coordinates
712 Try:
713 ' Initialize the dictionaries
714 With ScriptForge.SF_Services
717 End With
719 ' Initialize the root of the menu tree
722 ' Setup the display area
723 Set Rectangle = New com.sun.star.awt.Rectangle
724 Rectangle.X = plXPos
725 Rectangle.Y = plYPos
727 ' Keep the targeted window
728 Set PeerWindow = poPeer
730 ' Store the submenu character
733 Finally:
734 Exit Sub
735 End Sub ' SFWidgets.SF_PopupMenu._Initialize
737 REM -----------------------------------------------------------------------------
738 Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
739 ''' Return the value of the named property
740 ''' Args:
741 ''' psProperty: the name of the property
743 Dim vGet As Variant ' Return value
744 Dim cstThisSub As String
745 Const cstSubArgs = ""
748 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
750 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
751 _PropertyGet = Null
753 Select Case UCase(psProperty)
755 _PropertyGet = _UnderlineAccessKeyChar
757 _PropertyGet = SubmenuChar
758 Case Else
759 _PropertyGet = Null
760 End Select
762 Finally:
763 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
764 Exit Function
765 Catch:
766 GoTo Finally
767 End Function ' SFWidgets.SF_PopupMenu._PropertyGet
769 REM -----------------------------------------------------------------------------
770 Private Function _Repr() As String
771 ''' Convert the SF_PopupMenu instance to a readable string, typically for debugging purposes (DebugPrint ...)
772 ''' Args:
773 ''' Return:
774 ''' "[PopupMenu]: Name, Type (dialogname)
775 _Repr = "[PopupMenu]: " & SF_String.Represent(MenuTree.Keys()) & ", " & SF_String.Represent(MenuIdentification.Items())
777 End Function ' SFWidgets.SF_PopupMenu._Repr
779 REM -----------------------------------------------------------------------------
780 Private Function _SplitMenuItem(ByVal psMenuItem As String ) As Variant
781 ''' Split a menu item given as a string and delimited by the submenu character
782 ''' Args:
784 ''' Returns:
789 Dim vMenus() As Variant ' Array of menus
791 Try:
792 vMenus = Split(psMenuItem, SubmenuChar)
793 vReturn(1) = vMenus(UBound(vMenus))
794 vReturn(0) = Left(psMenuItem, Len(psMenuItem) - Iif(UBound(vMenus) > 0, Len(SubmenuChar), 0) - Len(vReturn(1)))
796 Finally:
797 _SplitMenuItem = vReturn
798 End Function ' SFWidgets.SF_PopupMenu._SplitMenuItem
800 REM ============================================ END OF SFWIDGETS.SF_POPUPMENU
801 </script:module>