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;
105  AImage: TQtImage;
106  Bmp: TBitmap;
107  AImgList: TImageList;
108begin
109  Result := TQtMenu.Create(AMenuItem);
110  Result.FDeleteLater := False;
111  Result.setSeparator(AMenuItem.IsLine);
112  Result.setHasSubmenu(AMenuItem.Count > 0);
113  if not AMenuItem.IsLine then
114  begin
115    Result.setText(GetUtf8String(AMenuItem.Caption));
116    Result.setEnabled(AMenuItem.Enabled);
117    Result.setCheckable(AMenuItem.RadioItem or AMenuItem.ShowAlwaysCheckable);
118    Result.BeginUpdate;
119    Result.setChecked(AMenuItem.Checked);
120    Result.EndUpdate;
121    Result.setShortcut(AMenuItem.ShortCut, AMenuItem.ShortCutKey2);
122    if AMenuItem.HasIcon then
123    begin
124      ImgList := AMenuItem.GetImageList;
125      // we must check so because AMenuItem.HasIcon can return true
126      // if Bitmap is setted up but not ImgList.
127      if (ImgList <> nil) and (AMenuItem.ImageIndex >= 0) and
128        (AMenuItem.ImageIndex < ImgList.Count) then
129      begin
130        ImgList.ResolutionForPPI[16, ScreenInfo.PixelsPerInchX, 1].GetBitmap(AMenuItem.ImageIndex, AMenuItem.Bitmap); // Qt bindings support only 16px icons for menu items
131        Result.setImage(TQtImage(AMenuItem.Bitmap.Handle));
132      end else
133      if Assigned(AMenuItem.Bitmap) then
134      begin
135        AImage := TQtImage(AMenuItem.Bitmap.Handle);
136        if not AMenuItem.Bitmap.Transparent then
137        begin
138          AImgList := TImageList.Create(nil);
139          AImgList.Width := AMenuItem.Bitmap.Width;
140          AImgList.Height := AMenuItem.Bitmap.Height;
141          AImgList.AddMasked(AMenuItem.Bitmap, AMenuItem.Bitmap.Canvas.Pixels[0, AMenuItem.Bitmap.Height -1]);
142          Bmp := TBitmap.Create;
143          AImgList.GetBitmap(0, Bmp);
144          AImage := TQtImage(Bmp.Handle);
145          Result.setImage(AImage);
146          Bmp.Free;
147          AImgList.Free;
148        end else
149          Result.setImage(AImage);
150      end;
151    end else
152      Result.setImage(nil);
153  end;
154end;
155{------------------------------------------------------------------------------
156  Function: TQtWSMenuItem.CreateHandle
157  Params:  None
158  Returns: Nothing
159
160  Creates a Menu Item
161 ------------------------------------------------------------------------------}
162class function TQtWSMenuItem.CreateHandle(const AMenuItem: TMenuItem): HMENU;
163var
164  Menu: TQtMenu;
165begin
166  {$ifdef VerboseQt}
167    WriteLn('trace:> [TQtWSMenuItem.CreateHandle] Caption: ', AMenuItem.Caption,
168     ' Subitems: ' + IntToStr(AMenuItem.Count));
169
170    Write('trace:< [TQtWSMenuItem.CreateHandle]');
171  {$endif}
172
173  Menu := nil;
174
175  {------------------------------------------------------------------------------
176    This case should not happen. A menu item must have a parent, but it seams LCL
177   will sometimes create a menu item prior to creating it's parent.
178    So, if we arrive here, we must create this item as if it was a TMenu
179   ------------------------------------------------------------------------------}
180  if (not AMenuItem.HasParent) then
181  begin
182    {$ifdef VerboseQt}
183      Write(' Parent: Menu without parent');
184    {$endif}
185
186    Result := TQtWSMenu.CreateHandle(AMenuItem.GetParentMenu);
187  end
188  {------------------------------------------------------------------------------
189    If the parent has no parent, then this item is directly owned by a TMenu
190    In this case we have to detect if the parent is a TMainMenu or a TPopUpMenu
191   because TMainMenu uses the special Handle QMenuBar while TPopUpMenu can be
192   treat like if this menu item was a subitem of another item
193   ------------------------------------------------------------------------------}
194  else
195  if ((not AMenuItem.Parent.HasParent) and (AMenuItem.GetParentMenu is TMainMenu)) then
196  begin
197    Menu := CreateMenuFromMenuItem(AMenuItem);
198    Result := HMENU(Menu);
199  end
200  {------------------------------------------------------------------------------
201    If the parent has a parent, then that item's Handle is necessarely a TQtMenu
202   ------------------------------------------------------------------------------}
203  else
204  begin
205    Menu := CreateMenuFromMenuItem(AMenuItem);
206    Result := HMENU(Menu);
207  end;
208
209  if Menu <> nil then
210    Menu.AttachEvents;
211
212  {$ifdef VerboseQt}
213    WriteLn(' Result: ', dbghex(Result));
214  {$endif}
215end;
216
217{------------------------------------------------------------------------------
218  Function: TQtWSMenuItem.DestroyHandle
219  Params:  None
220  Returns: Nothing
221
222  Dealocates a Menu Item
223 ------------------------------------------------------------------------------}
224class procedure TQtWSMenuItem.DestroyHandle(const AMenuItem: TMenuItem);
225var
226  Obj: TObject;
227begin
228  {$ifdef VerboseQt}
229    WriteLn('[TQtWSMenuItem.DestroyHandle] Caption: ' + AMenuItem.Caption);
230  {$endif}
231
232  if Assigned(AMenuItem.Owner) then
233  begin
234    if (AMenuItem.Owner is TMainMenu) and
235      Assigned(TMainMenu(AMenuItem.Owner).Parent) and
236      (
237      (TMainMenu(AMenuItem.Owner).Parent is TCustomForm) or
238      (TMainMenu(AMenuItem.Owner).Parent is TCustomFrame)
239      )
240       then
241    begin
242      {do not destroy menuitem handle if parent form handle = 0 - it's
243       already destroyed (TCustomForm.DestroyWnd isn't called when
244       LM_DESTROY is sent from TQtWidget.SlotDestroy() }
245      if not TWinControl(TMainMenu(AMenuItem.Owner).Parent).HandleAllocated then
246        exit;
247    end;
248  end;
249
250  Obj := TObject(AMenuItem.Handle);
251  if Obj is TQtMenu then
252    TQtMenu(Obj).Release;
253end;
254
255{------------------------------------------------------------------------------
256  Function: TQtWSMenuItem.SetCaption
257  Params:  None
258  Returns: Nothing
259 ------------------------------------------------------------------------------}
260class procedure TQtWSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
261var
262  Widget: TQtWidget;
263begin
264  {$ifdef VerboseQt}
265    WriteLn('[TQtWSMenuItem.SetCaption] Caption: ' + AMenuItem.Caption + ' NewCaption: ', ACaption);
266  {$endif}
267
268  if not WSCheckMenuItem(AMenuItem, 'SetCaption') then
269    Exit;
270
271  Widget := TQtWidget(AMenuItem.Handle);
272  if Widget is TQtMenu then
273  begin
274    TQtMenu(Widget).setSeparator(ACaption = cLineCaption);
275    if ACaption = cLineCaption then
276      TQtMenu(Widget).setText('')
277    else
278      TQtMenu(Widget).setText(GetUtf8String(ACaption));
279  end;
280end;
281
282{------------------------------------------------------------------------------
283  Function: TQtWSMenuItem.SetShortCut
284  Params:  None
285  Returns: Nothing
286 ------------------------------------------------------------------------------}
287class procedure TQtWSMenuItem.SetShortCut(const AMenuItem: TMenuItem;
288    const ShortCutK1, ShortCutK2: TShortCut);
289var
290  Widget: TQtWidget;
291begin
292  {$ifdef VerboseQt}
293    WriteLn('[TQtWSMenuItem.SetCaption] SetShortCut: ' + AMenuItem.Caption);
294  {$endif}
295
296  if not WSCheckMenuItem(AMenuItem, 'SetShortCut') then
297    Exit;
298
299  Widget := TQtWidget(AMenuItem.Handle);
300  if Widget is TQtMenu then
301    TQtMenu(Widget).setShortcut(ShortCutK1, ShortCutK2);
302end;
303
304{------------------------------------------------------------------------------
305  Function: TQtWSMenuItem.SetVisible
306  Params:  None
307  Returns: Nothing
308 ------------------------------------------------------------------------------}
309class procedure TQtWSMenuItem.SetVisible(const AMenuItem: TMenuItem; const Visible: boolean);
310begin
311  {$ifdef VerboseQt}
312    WriteLn('[TQtWSMenuItem.SetVisible] SetShortCut: ' + AMenuItem.Caption + ' Visible: ', Visible);
313  {$endif}
314  if not WSCheckMenuItem(AMenuItem, 'SetVisible') then
315    Exit;
316
317  TQtMenu(AMenuItem.Handle).setVisible(Visible);
318end;
319
320{------------------------------------------------------------------------------
321  Function: TQtWSMenuItem.SetCheck
322  Params:  None
323  Returns: Nothing
324 ------------------------------------------------------------------------------}
325class function TQtWSMenuItem.SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean;
326begin
327  Result := False;
328
329  if not WSCheckMenuItem(AMenuItem, 'SetCheck') then
330    Exit;
331
332  TQtMenu(AMenuItem.Handle).BeginUpdate;
333  TQtMenu(AMenuItem.Handle).setChecked(Checked);
334  TQtMenu(AMenuItem.Handle).EndUpdate;
335
336  Result := True;
337end;
338
339{------------------------------------------------------------------------------
340  Function: TQtWSMenuItem.SetEnable
341  Params:  None
342  Returns: Nothing
343 ------------------------------------------------------------------------------}
344class function TQtWSMenuItem.SetEnable(const AMenuItem: TMenuItem; const Enabled: boolean): boolean;
345begin
346  Result := False;
347
348  if not WSCheckMenuItem(AMenuItem, 'SetEnable') then
349    Exit;
350
351  TQtMenu(AMenuItem.Handle).setEnabled(Enabled);
352
353  Result := True;
354end;
355
356{------------------------------------------------------------------------------
357  Function: TQtWSMenuItem.SetRadioItem
358  Params:  None
359  Returns: Nothing
360 ------------------------------------------------------------------------------}
361class function TQtWSMenuItem.SetRadioItem(const AMenuItem: TMenuItem; const RadioItem: boolean): boolean;
362begin
363  Result := False;
364
365  if not WSCheckMenuItem(AMenuItem, 'SetRadioItem') then
366    Exit;
367
368  {$ifdef VerboseQt}
369    WriteLn('[TQtWSMenuItem.SetRadioItem] AMenuItem: ' + AMenuItem.Name +
370      ' Radio ? ',RadioItem);
371  {$endif}
372
373  if not RadioItem then
374    TQtMenu(AMenuItem.Handle).removeActionGroup;
375
376  TQtMenu(AMenuItem.Handle).setCheckable(RadioItem or AMenuItem.ShowAlwaysCheckable);
377  SetCheck(AMenuItem, AMenuItem.Checked);
378
379  Result := True;
380end;
381
382{------------------------------------------------------------------------------
383  Function: TQtWSMenuItem.SetRightJustify
384  Params:  None
385  Returns: Nothing
386 ------------------------------------------------------------------------------}
387class function TQtWSMenuItem.SetRightJustify(const AMenuItem: TMenuItem; const Justified: boolean): boolean;
388begin
389  if not WSCheckMenuItem(AMenuItem, 'SetRightJustify') then
390    Exit(False);
391
392  // what should be done here? maybe this?
393  TQtMenu(AMenuItem.Handle).setAttribute(QtWA_RightToLeft, Justified);
394  Result := True;
395end;
396
397class procedure TQtWSMenuItem.UpdateMenuIcon(const AMenuItem: TMenuItem;
398  const HasIcon: Boolean; const AIcon: TBitmap);
399begin
400  if AMenuItem.HasParent then
401  begin
402    if HasIcon then
403      TQtMenu(AMenuItem.Handle).setImage(TQtImage(AIcon.Handle))
404    else
405      TQtMenu(AMenuItem.Handle).setImage(nil);
406  end;
407end;
408
409{ TQtWSMenu }
410
411{------------------------------------------------------------------------------
412  Function: TQtWSMenu.CreateHandle
413  Params:  None
414  Returns: Nothing
415
416  Creates a Menu
417 ------------------------------------------------------------------------------}
418class function TQtWSMenu.CreateHandle(const AMenu: TMenu): HMENU;
419var
420  MenuBar: TQtMenuBar;
421  Menu: TQtMenu;
422  AParent: TComponent;
423begin
424  Result := 0;
425  { If the menu is a main menu, there is no need to create a handle for it.
426    It's already created on the window }
427  if (AMenu is TMainMenu) then
428  begin
429    AParent := AMenu.Parent;
430    if AParent = nil then
431      AParent := AMenu.Owner;
432    if Assigned(AParent) and
433      ((AParent is TCustomForm) or (AParent is TCustomFrame)) then
434    begin
435      if (AParent is TCustomForm) then
436        MenuBar := TQtMainWindow(TCustomForm(AParent).Handle).MenuBar
437      else
438        MenuBar := TQtMainWindow(TCustomFrame(AParent).Handle).MenuBar;
439      Result := HMENU(MenuBar);
440    end else
441    begin
442      Menu := TQtMenu.Create(AMenu.Items);
443      Menu.AttachEvents;
444      Result := HMENU(Menu);
445    end;
446  end else
447  if (AMenu is TPopUpMenu) then
448  begin
449    Menu := TQtMenu.Create(AMenu.Items);
450    Menu.AttachEvents;
451    Result := HMENU(Menu);
452  end;
453
454  {$ifdef VerboseQt}
455    Write('[TQtWSMenu.CreateHandle] ');
456    if (AMenu is TMainMenu) then Write('IsMainMenu ');
457    WriteLn(' Handle: ', dbghex(Result), ' Name: ', AMenu.Name);
458  {$endif}
459end;
460
461class procedure TQtWSMenu.SetBiDiMode(const AMenu : TMenu; UseRightToLeftAlign,
462  UseRightToLeftReading : Boolean);
463begin
464  TQtWidget(AMenu.Handle).setLayoutDirection(TLayoutDirectionMap[UseRightToLeftAlign]);
465end;
466
467
468{ TQtWSPopupMenu }
469
470{------------------------------------------------------------------------------
471  Function: TQtWSPopupMenu.Popup
472  Params:  None
473  Returns: Nothing
474
475  Creates a PopUp menu
476 ------------------------------------------------------------------------------}
477class procedure TQtWSPopupMenu.Popup(const APopupMenu: TPopupMenu; const X, Y: integer);
478var
479  Point: TQtPoint;
480  Size: TSize;
481  Alignment: TPopupAlignment;
482begin
483  {$ifdef VerboseQt}
484    WriteLn('[TQtWSPopupMenu.Popup] APopupMenu.Handle ' + dbghex(APopupMenu.Handle)
485     + ' FirstItemName: ' + APopupMenu.Items.Name
486     + ' FirstItemWND: ' + IntToStr(APopupMenu.Items.Handle)
487     + ' FirstItemCount: ' + IntToStr(APopupMenu.Items.Count));
488  {$endif}
489
490  Point.X := X;
491  Point.Y := Y;
492  Alignment := APopupMenu.Alignment;
493
494  if APopupMenu.IsRightToLeft then
495  begin
496    if Alignment = paLeft then
497      Alignment := paRight
498    else
499    if Alignment = paRight then
500      Alignment := paLeft;
501  end;
502
503  case Alignment of
504    paCenter:
505      begin
506        QMenu_sizeHint(QMenuH(TQtMenu(APopupMenu.Handle).Widget), @Size);
507        Point.X := Point.X - (Size.cx div 2);
508      end;
509    paRight:
510      begin
511        QMenu_sizeHint(QMenuH(TQtMenu(APopupMenu.Handle).Widget), @Size);
512        Point.X := Point.X - Size.cx;
513      end;
514  end;
515
516  if APopupMenu.TrackButton = tbLeftButton then
517    TQtMenu(APopupMenu.Handle).trackButton := QtLeftButton
518  else
519    TQtMenu(APopupMenu.Handle).trackButton := QtRightButton;
520
521  // for win32 compatibility do a blocking call
522  TQtMenu(APopupMenu.Handle).Exec(@Point);
523end;
524
525end.
526