source: trunk/Packages/DpiControls/Dpi.Menus.pas

Last change on this file was 526, checked in by chronos, 6 months ago
  • Fixed: Error if AI context menu opened multiple times. Also memory leaks if Nations context menu opened multiple times. DPI menu items were not correctly cleared.
File size: 9.1 KB
Line 
1unit Dpi.Menus;
2
3interface
4
5uses
6 Classes, SysUtils, LCLType, Menus;
7
8type
9 { TMenuItem }
10
11 TMenuItem = class(TComponent)
12 private
13 FItems: TList;
14 FParent: TMenuItem;
15 FOnClick: TNotifyEvent;
16 function GetCaption: TTranslateString;
17 function GetChecked: Boolean;
18 function GetCount: Integer;
19 function GetEnabled: Boolean;
20 function GetGroupIndex: Byte;
21 function GetItem(Index: Integer): TMenuItem;
22 function GetOnClick: TNotifyEvent;
23 function GetRadioItem: Boolean;
24 function GetShortCut: TShortCut;
25 function GetVisible: Boolean;
26 function IsCaptionStored: Boolean;
27 function IsCheckedStored: Boolean;
28 function IsEnabledStored: Boolean;
29 function IsShortCutStored: Boolean;
30 function IsVisibleStored: Boolean;
31 procedure SetCaption(AValue: TTranslateString);
32 procedure SetChecked(AValue: Boolean);
33 procedure SetEnabled(AValue: Boolean);
34 procedure SetGroupIndex(AValue: Byte);
35 procedure SetOnClick(AValue: TNotifyEvent);
36 procedure SetRadioItem(AValue: Boolean);
37 procedure SetShortCut(AValue: TShortCut);
38 procedure SetVisible(AValue: Boolean);
39 procedure OnClickHandler(Sender: TObject);
40 protected
41 function GetNativeMenuItem: Menus.TMenuItem; virtual;
42 procedure SetParentComponent(AValue: TComponent); override;
43 public
44 NativeMenuItem: Menus.TMenuItem;
45 constructor Create(AOwner: TComponent); override;
46 destructor Destroy; override;
47 procedure Delete(Index: Integer);
48 procedure Add(Item: TMenuItem);
49 procedure Insert(Index: Integer; Item: TMenuItem);
50 function IndexOf(Item: TMenuItem): Integer;
51 procedure Remove(Item: TMenuItem);
52 property Items[Index: Integer]: TMenuItem read GetItem; default;
53 property Count: Integer read GetCount;
54 procedure Clear;
55 procedure Click; virtual;
56 published
57 property RadioItem: Boolean read GetRadioItem write SetRadioItem default False;
58 property ShortCut: TShortCut read GetShortCut write SetShortCut
59 stored IsShortCutStored default 0;
60 property Enabled: Boolean read GetEnabled write SetEnabled
61 stored IsEnabledStored default True;
62 property Visible: Boolean read GetVisible write SetVisible
63 stored IsVisibleStored default True;
64 property Checked: Boolean read GetChecked write SetChecked
65 stored IsCheckedStored default False;
66 property Caption: TTranslateString read GetCaption write SetCaption
67 stored IsCaptionStored;
68 property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
69 property GroupIndex: Byte read GetGroupIndex write SetGroupIndex default 0;
70 end;
71
72 TMenu = class(TComponent)
73 private
74 FItems: TMenuItem;
75 protected
76 function GetNativeMenu: Menus.TMenu; virtual;
77 public
78 property Items: TMenuItem read FItems;
79 constructor Create(AOwner: TComponent); override;
80 destructor Destroy; override;
81 end;
82
83 { TPopupMenu }
84
85 TPopupMenu = class(TMenu)
86 private
87 function GetAutoPopup: Boolean;
88 procedure SetAutoPopup(AValue: Boolean);
89 protected
90 function GetNativeMenu: Menus.TMenu; override;
91 function GetNativePopupMenu: Menus.TPopupMenu; virtual;
92 public
93 NativePopupMenu: Menus.TPopupMenu;
94 procedure PopUp; overload;
95 procedure PopUp(X, Y: Integer); virtual; overload;
96 constructor Create(AOwner: TComponent); override;
97 destructor Destroy; override;
98 published
99 property AutoPopup: Boolean read GetAutoPopup write SetAutoPopup default True;
100 end;
101
102function ShortCut(const Key: Word; const Shift: TShiftState): TShortCut;
103procedure Register;
104
105
106implementation
107
108uses
109 Dpi.Common, Dpi.Controls, LCLStrConsts;
110
111function ShortCut(const Key: Word; const Shift: TShiftState): TShortCut;
112begin
113 Result := Menus.ShortCut(Key, Shift);
114end;
115
116procedure Register;
117begin
118 RegisterComponents(DpiControlsComponentPaletteName, [TPopupMenu]);
119end;
120
121{ TMenu }
122
123function TMenu.GetNativeMenu: Menus.TMenu;
124begin
125 Result := nil;
126end;
127
128constructor TMenu.Create(AOwner: TComponent);
129begin
130 inherited;
131 FItems := TMenuItem.Create(Self);
132end;
133
134destructor TMenu.Destroy;
135begin
136 FreeAndNil(FItems);
137 inherited;
138end;
139
140{ TMenuItem }
141
142function TMenuItem.GetCaption: TTranslateString;
143begin
144 Result := GetNativeMenuItem.Caption;
145end;
146
147function TMenuItem.GetChecked: Boolean;
148begin
149 Result := GetNativeMenuItem.Checked;
150end;
151
152function TMenuItem.GetCount: Integer;
153begin
154 Result := FItems.Count;
155end;
156
157function TMenuItem.GetEnabled: Boolean;
158begin
159 Result := GetNativeMenuItem.Enabled;
160end;
161
162function TMenuItem.GetGroupIndex: Byte;
163begin
164 Result := GetNativeMenuItem.GroupIndex;
165end;
166
167function TMenuItem.GetItem(Index: Integer): TMenuItem;
168begin
169 Result := TMenuItem(FItems[Index]);
170end;
171
172function TMenuItem.GetOnClick: TNotifyEvent;
173begin
174 Result := FOnClick;
175end;
176
177function TMenuItem.GetRadioItem: Boolean;
178begin
179 Result := GetNativeMenuItem.RadioItem;
180end;
181
182function TMenuItem.GetShortCut: TShortCut;
183begin
184 Result := GetNativeMenuItem.ShortCut;
185end;
186
187function TMenuItem.GetVisible: Boolean;
188begin
189 Result := GetNativeMenuItem.Visible;
190end;
191
192function TMenuItem.IsCaptionStored: Boolean;
193begin
194 Result := False;
195end;
196
197function TMenuItem.IsCheckedStored: Boolean;
198begin
199 Result := False;
200end;
201
202function TMenuItem.IsEnabledStored: Boolean;
203begin
204 Result := False;
205end;
206
207function TMenuItem.IsShortCutStored: Boolean;
208begin
209 Result := False;
210end;
211
212function TMenuItem.IsVisibleStored: Boolean;
213begin
214 Result := False;
215end;
216
217procedure TMenuItem.SetCaption(AValue: TTranslateString);
218begin
219 GetNativeMenuItem.Caption := AValue;
220end;
221
222procedure TMenuItem.SetChecked(AValue: Boolean);
223begin
224 GetNativeMenuItem.Checked := AValue;
225end;
226
227procedure TMenuItem.SetEnabled(AValue: Boolean);
228begin
229 GetNativeMenuItem.Enabled := AValue;
230end;
231
232procedure TMenuItem.SetGroupIndex(AValue: Byte);
233begin
234 GetNativeMenuItem.GroupIndex := AValue;
235end;
236
237procedure TMenuItem.SetOnClick(AValue: TNotifyEvent);
238begin
239 FOnClick := AValue;
240end;
241
242procedure TMenuItem.SetRadioItem(AValue: Boolean);
243begin
244 GetNativeMenuItem.RadioItem := AValue;
245end;
246
247procedure TMenuItem.SetShortCut(AValue: TShortCut);
248begin
249 GetNativeMenuItem.ShortCut := AValue;
250end;
251
252procedure TMenuItem.SetVisible(AValue: Boolean);
253begin
254 GetNativeMenuItem.Visible := AValue;
255end;
256
257procedure TMenuItem.OnClickHandler(Sender: TObject);
258begin
259 if Assigned(FOnClick) then
260 FOnClick(Self);
261end;
262
263procedure TMenuItem.Delete(Index: Integer);
264begin
265 FItems.Delete(Index);
266 GetNativeMenuItem.Delete(Index);
267end;
268
269procedure TMenuItem.Add(Item: TMenuItem);
270begin
271 Insert(GetCount, Item);
272end;
273
274procedure TMenuItem.Insert(Index: Integer; Item: TMenuItem);
275begin
276 FItems.Insert(Index, Item);
277 GetNativeMenuItem.Insert(Index, Item.GetNativeMenuItem);
278end;
279
280function TMenuItem.IndexOf(Item: TMenuItem): Integer;
281begin
282 if FItems = nil then
283 Result := -1
284 else
285 Result := FItems.IndexOf(Item);
286end;
287
288procedure TMenuItem.Remove(Item: TMenuItem);
289var
290 I: Integer;
291begin
292 I := IndexOf(Item);
293 if I < 0 then
294 raise EMenuError.Create(SMenuNotFound);
295 Delete(I);
296end;
297
298procedure TMenuItem.Clear;
299begin
300 GetNativeMenuItem.Clear;
301 FItems.Clear;
302end;
303
304procedure TMenuItem.Click;
305begin
306 GetNativeMenuItem.Click;
307end;
308
309function TMenuItem.GetNativeMenuItem: Menus.TMenuItem;
310begin
311 if not Assigned(NativeMenuItem) then begin
312 NativeMenuItem := Menus.TMenuItem.Create(nil);
313 NativeMenuItem.Name := 'Native' + Name;
314 NativeMenuItem.OnClick := OnClickHandler;
315 end;
316 Result := NativeMenuItem;
317end;
318
319procedure TMenuItem.SetParentComponent(AValue: TComponent);
320begin
321 if (FParent = AValue) then Exit;
322 if Assigned(FParent) then FParent.Remove(Self);
323 if Assigned(AValue) then
324 begin
325 if (AValue is TMenu)
326 then TMenu(AValue).Items.Add(Self)
327 else if (AValue is TMenuItem)
328 then TMenuItem(AValue).Add(Self)
329 else
330 raise Exception.Create('TDpiMenuItem.SetParentComponent: suggested parent not of type TDpiMenu or TDpiMenuItem');
331 end;
332end;
333
334constructor TMenuItem.Create(AOwner: TComponent);
335begin
336 inherited;
337 FItems := TList.Create;
338end;
339
340destructor TMenuItem.Destroy;
341begin
342 FreeAndNil(FItems);
343 // TODO: Release menu items
344 //FreeAndNil(NativeMenuItem);
345 inherited;
346end;
347
348{ TPopupMenu }
349
350procedure TPopupMenu.PopUp;
351var
352 Pos: TPoint;
353begin
354 Pos := Mouse.CursorPos;
355 Popup(Pos.X, Pos.Y);
356end;
357
358procedure TPopupMenu.PopUp(X, Y: Integer);
359begin
360 GetNativePopupMenu.PopUp(ScaleToNative(X), ScaleToNative(Y));
361end;
362
363constructor TPopupMenu.Create(AOwner: TComponent);
364begin
365 inherited;
366 GetNativePopupMenu;
367end;
368
369function TPopupMenu.GetAutoPopup: Boolean;
370begin
371 Result := GetNativePopupMenu.AutoPopup;
372end;
373
374procedure TPopupMenu.SetAutoPopup(AValue: Boolean);
375begin
376 GetNativePopupMenu.AutoPopup := AValue;
377end;
378
379function TPopupMenu.GetNativeMenu: Menus.TMenu;
380begin
381 Result := GetNativePopupMenu;
382end;
383
384function TPopupMenu.GetNativePopupMenu: Menus.TPopupMenu;
385begin
386 if not Assigned(NativePopupMenu) then begin
387 NativePopupMenu := Menus.TPopupMenu.Create(nil);
388 if Assigned(Items.NativeMenuItem) then Items.NativeMenuItem.Free;
389 Items.NativeMenuItem := NativePopupMenu.Items;
390 end;
391 Result := NativePopupMenu;
392end;
393
394destructor TPopupMenu.Destroy;
395begin
396 if Assigned(NativePopupMenu) then FreeAndNil(NativePopupMenu);
397 inherited;
398end;
399
400
401end.
402
Note: See TracBrowser for help on using the repository browser.