1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
|
<?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>
|
