1{
2 *****************************************************************************
3 *                               QtWSMenus.pp                                *
4 *                               ------------                                *
5 *                                                                           *
6 *                                                                           *
7 *****************************************************************************
8
9 *****************************************************************************
10  This file is part of the Lazarus Component Library (LCL)
11
12  See the file COPYING.modifiedLGPL.txt, included in this distribution,
13  for details about the license.
14 *****************************************************************************
15}
16unit QtWSMenus;
17
18{$mode objfpc}{$H+}
19
20interface
21
22{$I qtdefines.inc}
23
24uses
25  // Bindings
26  qt5,
27  qtwidgets, qtobjects, qtproc, QtWsControls,
28  // LCL
29  SysUtils, Classes, Types, LCLType, LCLProc, Graphics, Controls, Forms, Menus,
30  ImgList,
31  // Widgetset
32  WSMenus, WSLCLClasses;
33
34type
35
36  { TQtWSMenuItem }
37
38  TQtWSMenuItem = class(TWSMenuItem)
39  protected
40    class function CreateMenuFromMenuItem(const AMenuItem: TMenuItem): TQtMenu;
41  published
42    class procedure AttachMenu(const AMenuItem: TMenuItem); override;
43    class function CreateHandle(const AMenuItem: TMenuItem): HMENU; override;
44    class procedure DestroyHandle(const AMenuItem: TMenuItem); override;
45    class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
46    class procedure SetShortCut(const AMenuItem: TMenuItem; const ShortCutK1, ShortCutK2: TShortCut); override;
47    class procedure SetVisible(const AMenuItem: TMenuItem; const Visible: boolean); override;
48    class function SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean; override;
49    class function SetEnable(const AMenuItem: TMenuItem; const Enabled: boolean): boolean; override;
50    class function SetRadioItem(const AMenuItem: TMenuItem; const RadioItem: boolean): boolean; override;
51    class function SetRightJustify(const AMenuItem: TMenuItem; const Justified: boolean): boolean; override;
52    class procedure UpdateMenuIcon(const AMenuItem: TMenuItem; const HasIcon: Boolean; const AIcon: TBitmap); override;
53  end;
54
55  { TQtWSMenu }
56
57  TQtWSMenu = class(TWSMenu)
58  published
59    class function  CreateHandle(const AMenu: TMenu): HMENU; override;
60    class procedure SetBiDiMode(const AMenu: TMenu; UseRightToLeftAlign, UseRightToLeftReading : Boolean); override;
61  end;
62
63  { TQtWSMainMenu }
64
65  TQtWSMainMenu = class(TWSMainMenu)
66  published
67  end;
68
69  { TQtWSPopupMenu }
70
71  TQtWSPopupMenu = class(TWSPopupMenu)
72  published
73    class procedure Popup(const APopupMenu: TPopupMenu; const X, Y: integer); override;
74  end;
75
76
77implementation
78
79{ TQtWSMenuItem }
80
81{------------------------------------------------------------------------------
82  Function: TQtWSMenuItem.AttachMenu
83  Params:  None
84  Returns: Nothing
85 ------------------------------------------------------------------------------}
86class procedure TQtWSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
87var
88  Widget: TQtWidget;
89begin
90  if not WSCheckMenuItem(AMenuItem, 'AttachMenu') or (AMenuItem.Parent = nil) then
91    Exit;
92  Widget := TQtWidget(AMenuItem.Parent.Handle);
93  if Widget is TQtMenuBar then
94    TQtMenuBar(Widget).insertMenu(AMenuItem.Parent.VisibleIndexOf(AMenuItem),
95      QMenuH(TQtMenu(AMenuItem.Handle).Widget))
96  else
97  if Widget is TQtMenu then
98    TQtMenu(Widget).insertMenu(AMenuItem.Parent.VisibleIndexOf(AMenuItem),
99      QMenuH(TQtMenu(AMenuItem.Handle).Widget), AMenuItem);
100end;
101
102class function TQtWSMenuItem.CreateMenuFromMenuItem(const AMenuItem: TMenuItem): TQtMenu;
103var
104  ImgList: TCustomImageList;
105begin
106  Result := TQtMenu.Create(AMenuItem);
107  Result.FDeleteLater := False;
108  Result.setSeparator(AMenuItem.IsLine);
109  Result.setHasSubmenu(AMenuItem.Count > 0);
110  if not AMenuItem.IsLine then
111  begin
112    Result.setText(GetUtf8String(AMenuItem.Caption));
113    Result.setEnabled(AMenuItem.Enabled);
114    Result.setCheckable(AMenuItem.RadioItem or AMenuItem.ShowAlwaysCheckable);
115    Result.BeginUpdate;
116    Result.setChecked(AMenuItem.Checked);
117    Result.EndUpdate;
118    Result.setShortcut(AMenuItem.ShortCut, AMenuItem.ShortCutKey2);
119    if AMenuItem.HasIcon then
120    begin
121      ImgList := AMenuItem.GetImageList;
122      // we must check so because AMenuItem.HasIcon can return true
123      // if Bitmap is setted up but not ImgList.
124      if (ImgList <> nil) and (AMenuItem.ImageIndex >= 0) and
125        (AMenuItem.ImageIndex < ImgList.Count) then
126      begin
127        ImgList.ResolutionForPPI[16, ScreenInfo.PixelsPerInchX, 1].GetBitmap(AMenuItem.ImageIndex, AMenuItem.Bitmap); // Qt bindings support only 16px icons for menu items
128        Result.setImage(TQtImage(AMenuItem.Bitmap.Handle));
129      end else
130      if Assigned(AMenuItem.Bitmap) then
131        Result.setImage(TQtImage(AMenuItem.Bitmap.Handle));
132    end else
133      Result.setImage(nil);
134  end;
135end;
136{------------------------------------------------------------------------------
137  Function: TQtWSMenuItem.CreateHandle
138  Params:  None
139  Returns: Nothing
140
141  Creates a Menu Item
142 ------------------------------------------------------------------------------}
143class function TQtWSMenuItem.CreateHandle(const AMenuItem: TMenuItem): HMENU;
144var
145  Menu: TQtMenu;
146begin
147  {$ifdef VerboseQt}
148    WriteLn('trace:> [TQtWSMenuItem.CreateHandle] Caption: ', AMenuItem.Caption,
149     ' Subitems: ' + IntToStr(AMenuItem.Count));
150
151    Write('trace:< [TQtWSMenuItem.CreateHandle]');
152  {$endif}
153
154  Menu := nil;
155
156  {------------------------------------------------------------------------------
157    This case should not happen. A menu item must have a parent, but it seams LCL
158   will sometimes create a menu item prior to creating it's parent.
159    So, if we arrive here, we must create this item as if it was a TMenu
160   ------------------------------------------------------------------------------}
161  if (not AMenuItem.HasParent) then
162  begin
163    {$ifdef VerboseQt}
164      Write(' Parent: Menu without parent');
165    {$endif}
166
167    Result := TQtWSMenu.CreateHandle(AMenuItem.GetParentMenu);
168  end
169  {------------------------------------------------------------------------------
170    If the parent has no parent, then this item is directly owned by a TMenu
171    In this case we have to detect if the parent is a TMainMenu or a TPopUpMenu
172   because TMainMenu uses the special Handle QMenuBar while TPopUpMenu can be
173   treat like if this menu item was a subitem of another item
174   ------------------------------------------------------------------------------}
175  else
176  if ((not AMenuItem.Parent.HasParent) and (AMenuItem.GetParentMenu is TMainMenu)) then
177  begin
178    Menu := CreateMenuFromMenuItem(AMenuItem);
179    Result := HMENU(Menu);
180  end
181  {------------------------------------------------------------------------------
182    If the parent has a parent, then that item's Handle is necessarely a TQtMenu
183   ------------------------------------------------------------------------------}
184  else
185  begin
186    Menu := CreateMenuFromMenuItem(AMenuItem);
187    Result := HMENU(Menu);
188  end;
189
190  if Menu <> nil then
191    Menu.AttachEvents;
192
193  {$ifdef VerboseQt}
194    WriteLn(' Result: ', dbghex(Result));
195  {$endif}
196end;
197
198{------------------------------------------------------------------------------
199  Function: TQtWSMenuItem.DestroyHandle
200  Params:  None
201  Returns: Nothing
202
203  Dealocates a Menu Item
204 ------------------------------------------------------------------------------}
205class procedure TQtWSMenuItem.DestroyHandle(const AMenuItem: TMenuItem);
206var
207  Obj: TObject;
208begin
209  {$ifdef VerboseQt}
210    WriteLn('[TQtWSMenuItem.DestroyHandle] Caption: ' + AMenuItem.Caption);
211  {$endif}
212
213  if Assigned(AMenuItem.Owner) then
214  begin
215    if (AMenuItem.Owner is TMainMenu) and
216      Assigned(TMainMenu(AMenuItem.Owner).Parent) and
217      (
218      (TMainMenu(AMenuItem.Owner).Parent is TCustomForm) or
219      (TMainMenu(AMenuItem.Owner).Parent is TCustomFrame)
220      )
221       then
222    begin
223      {do not destroy menuitem handle if parent form handle = 0 - it's
224       already destroyed (TCustomForm.DestroyWnd isn't called when
225       LM_DESTROY is sent from TQtWidget.SlotDestroy() }
226      if not TWinControl(TMainMenu(AMenuItem.Owner).Parent).HandleAllocated then
227        exit;
228    end;
229  end;
230
231  Obj := TObject(AMenuItem.Handle);
232  if Obj is TQtMenu then
233    TQtMenu(Obj).Release;
234end;
235
236{------------------------------------------------------------------------------
237  Function: TQtWSMenuItem.SetCaption
238  Params:  None
239  Returns: Nothing
240 ------------------------------------------------------------------------------}
241class procedure TQtWSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
242var
243  Widget: TQtWidget;
244begin
245  {$ifdef VerboseQt}
246    WriteLn('[TQtWSMenuItem.SetCaption] Caption: ' + AMenuItem.Caption + ' NewCaption: ', ACaption);
247  {$endif}
248
249  if not WSCheckMenuItem(AMenuItem, 'SetCaption') then
250    Exit;
251
252  Widget := TQtWidget(AMenuItem.Handle);
253  if Widget is TQtMenu then
254  begin
255    TQtMenu(Widget).setSeparator(ACaption = cLineCaption);
256    if ACaption = cLineCaption then
257      TQtMenu(Widget).setText('')
258    else
259      TQtMenu(Widget).setText(GetUtf8String(ACaption));
260  end;
261end;
262
263{------------------------------------------------------------------------------
264  Function: TQtWSMenuItem.SetShortCut
265  Params:  None
266  Returns: Nothing
267 ------------------------------------------------------------------------------}
268class procedure TQtWSMenuItem.SetShortCut(const AMenuItem: TMenuItem;
269    const ShortCutK1, ShortCutK2: TShortCut);
270var
271  Widget: TQtWidget;
272begin
273  {$ifdef VerboseQt}
274    WriteLn('[TQtWSMenuItem.SetCaption] SetShortCut: ' + AMenuItem.Caption);
275  {$endif}
276
277  if not WSCheckMenuItem(AMenuItem, 'SetShortCut') then
278    Exit;
279
280  Widget := TQtWidget(AMenuItem.Handle);
281  if Widget is TQtMenu then
282    TQtMenu(Widget).setShortcut(ShortCutK1, ShortCutK2);
283end;
284
285{------------------------------------------------------------------------------
286  Function: TQtWSMenuItem.SetVisible
287  Params:  None
288  Returns: Nothing
289 ------------------------------------------------------------------------------}
290class procedure TQtWSMenuItem.SetVisible(const AMenuItem: TMenuItem; const Visible: boolean);
291begin
292  {$ifdef VerboseQt}
293    WriteLn('[TQtWSMenuItem.SetVisible] SetShortCut: ' + AMenuItem.Caption + ' Visible: ', Visible);
294  {$endif}
295  if not WSCheckMenuItem(AMenuItem, 'SetVisible') then
296    Exit;
297
298  TQtMenu(AMenuItem.Handle).setVisible(Visible);
299end;
300
301{------------------------------------------------------------------------------
302  Function: TQtWSMenuItem.SetCheck
303  Params:  None
304  Returns: Nothing
305 ------------------------------------------------------------------------------}
306class function TQtWSMenuItem.SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean;
307begin
308  Result := False;
309
310  if not WSCheckMenuItem(AMenuItem, 'SetCheck') then
311    Exit;
312
313  TQtMenu(AMenuItem.Handle).BeginUpdate;
314  TQtMenu(AMenuItem.Handle).setChecked(Checked);
315  TQtMenu(AMenuItem.Handle).EndUpdate;
316
317  Result := True;
318end;
319
320{------------------------------------------------------------------------------
321  Function: TQtWSMenuItem.SetEnable
322  Params:  None
323  Returns: Nothing
324 ------------------------------------------------------------------------------}
325class function TQtWSMenuItem.SetEnable(const AMenuItem: TMenuItem; const Enabled: boolean): boolean;
326begin
327  Result := False;
328
329  if not WSCheckMenuItem(AMenuItem, 'SetEnable') then
330    Exit;
331
332  TQtMenu(AMenuItem.Handle).setEnabled(Enabled);
333
334  Result := True;
335end;
336
337{------------------------------------------------------------------------------
338  Function: TQtWSMenuItem.SetRadioItem
339  Params:  None
340  Returns: Nothing
341 ------------------------------------------------------------------------------}
342class function TQtWSMenuItem.SetRadioItem(const AMenuItem: TMenuItem; const RadioItem: boolean): boolean;
343begin
344  Result := False;
345
346  if not WSCheckMenuItem(AMenuItem, 'SetRadioItem') then
347    Exit;
348
349  {$ifdef VerboseQt}
350    WriteLn('[TQtWSMenuItem.SetRadioItem] AMenuItem: ' + AMenuItem.Name +
351      ' Radio ? ',RadioItem);
352  {$endif}
353
354  if not RadioItem then
355    TQtMenu(AMenuItem.Handle).removeActionGroup;
356
357  TQtMenu(AMenuItem.Handle).setCheckable(RadioItem or AMenuItem.ShowAlwaysCheckable);
358  SetCheck(AMenuItem, AMenuItem.Checked);
359
360  Result := True;
361end;
362
363{------------------------------------------------------------------------------
364  Function: TQtWSMenuItem.SetRightJustify
365  Params:  None
366  Returns: Nothing
367 ------------------------------------------------------------------------------}
368class function TQtWSMenuItem.SetRightJustify(const AMenuItem: TMenuItem; const Justified: boolean): boolean;
369begin
370  if not WSCheckMenuItem(AMenuItem, 'SetRightJustify') then
371    Exit(False);
372
373  // what should be done here? maybe this?
374  TQtMenu(AMenuItem.Handle).setAttribute(QtWA_RightToLeft, Justified);
375  Result := True;
376end;
377
378class procedure TQtWSMenuItem.UpdateMenuIcon(const AMenuItem: TMenuItem;
379  const HasIcon: Boolean; const AIcon: TBitmap);
380begin
381  if AMenuItem.HasParent then
382  begin
383    if HasIcon then
384      TQtMenu(AMenuItem.Handle).setImage(TQtImage(AIcon.Handle))
385    else
386      TQtMenu(AMenuItem.Handle).setImage(nil);
387  end;
388end;
389
390{ TQtWSMenu }
391
392{------------------------------------------------------------------------------
393  Function: TQtWSMenu.CreateHandle
394  Params:  None
395  Returns: Nothing
396
397  Creates a Menu
398 ------------------------------------------------------------------------------}
399class function TQtWSMenu.CreateHandle(const AMenu: TMenu): HMENU;
400var
401  MenuBar: TQtMenuBar;
402  Menu: TQtMenu;
403  AParent: TComponent;
404begin
405  Result := 0;
406  { If the menu is a main menu, there is no need to create a handle for it.
407    It's already created on the window }
408  if (AMenu is TMainMenu) then
409  begin
410    AParent := AMenu.Parent;
411    if AParent = nil then
412      AParent := AMenu.Owner;
413    if Assigned(AParent) and
414      ((AParent is TCustomForm) or (AParent is TCustomFrame)) then
415    begin
416      if (AParent is TCustomForm) then
417        MenuBar := TQtMainWindow(TCustomForm(AParent).Handle).MenuBar
418      else
419        MenuBar := TQtMainWindow(TCustomFrame(AParent).Handle).MenuBar;
420      Result := HMENU(MenuBar);
421    end else
422    begin
423      Menu := TQtMenu.Create(AMenu.Items);
424      Menu.AttachEvents;
425      Result := HMENU(Menu);
426    end;
427  end else
428  if (AMenu is TPopUpMenu) then
429  begin
430    Menu := TQtMenu.Create(AMenu.Items);
431    Menu.AttachEvents;
432    Result := HMENU(Menu);
433  end;
434
435  {$ifdef VerboseQt}
436    Write('[TQtWSMenu.CreateHandle] ');
437    if (AMenu is TMainMenu) then Write('IsMainMenu ');
438    WriteLn(' Handle: ', dbghex(Result), ' Name: ', AMenu.Name);
439  {$endif}
440end;
441
442class procedure TQtWSMenu.SetBiDiMode(const AMenu : TMenu; UseRightToLeftAlign,
443  UseRightToLeftReading : Boolean);
444begin
445  TQtWidget(AMenu.Handle).setLayoutDirection(TLayoutDirectionMap[UseRightToLeftAlign]);
446end;
447
448
449{ TQtWSPopupMenu }
450
451{------------------------------------------------------------------------------
452  Function: TQtWSPopupMenu.Popup
453  Params:  None
454  Returns: Nothing
455
456  Creates a PopUp menu
457 ------------------------------------------------------------------------------}
458class procedure TQtWSPopupMenu.Popup(const APopupMenu: TPopupMenu; const X, Y: integer);
459var
460  Point: TQtPoint;
461  Size: TSize;
462  Alignment: TPopupAlignment;
463begin
464  {$ifdef VerboseQt}
465    WriteLn('[TQtWSPopupMenu.Popup] APopupMenu.Handle ' + dbghex(APopupMenu.Handle)
466     + ' FirstItemName: ' + APopupMenu.Items.Name
467     + ' FirstItemWND: ' + IntToStr(APopupMenu.Items.Handle)
468     + ' FirstItemCount: ' + IntToStr(APopupMenu.Items.Count));
469  {$endif}
470
471  Point.X := X;
472  Point.Y := Y;
473  Alignment := APopupMenu.Alignment;
474
475  if APopupMenu.IsRightToLeft then
476  begin
477    if Alignment = paLeft then
478      Alignment := paRight
479    else
480    if Alignment = paRight then
481      Alignment := paLeft;
482  end;
483
484  case Alignment of
485    paCenter:
486      begin
487        QMenu_sizeHint(QMenuH(TQtMenu(APopupMenu.Handle).Widget), @Size);
488        Point.X := Point.X - (Size.cx div 2);
489      end;
490    paRight:
491      begin
492        QMenu_sizeHint(QMenuH(TQtMenu(APopupMenu.Handle).Widget), @Size);
493        Point.X := Point.X - Size.cx;
494      end;
495  end;
496
497  if APopupMenu.TrackButton = tbLeftButton then
498    TQtMenu(APopupMenu.Handle).trackButton := QtLeftButton
499  else
500    TQtMenu(APopupMenu.Handle).trackButton := QtRightButton;
501
502  // for win32 compatibility do a blocking call
503  TQtMenu(APopupMenu.Handle).Exec(@Point);
504end;
505
506end.
507