source: cprs/branches/tmg-cprs/TntWare/Delphi Unicode Controls/Source/TntMenus.pas@ 1647

Last change on this file since 1647 was 453, checked in by Kevin Toppenberg, 17 years ago

Initial upload of TMG-CPRS 1.0.26.69
File size: 35.6 KB
Line 
1
2{*****************************************************************************}
3{ }
4{ Tnt Delphi Unicode Controls }
5{ http://www.tntware.com/delphicontrols/unicode/ }
6{ Version: 2.3.0 }
7{ }
8{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
9{ }
10{*****************************************************************************}
11
12unit TntMenus;
13
14{$INCLUDE TntCompilers.inc}
15
16interface
17
18uses
19 Windows, Classes, Menus, Graphics, Messages;
20
21type
22{TNT-WARN TMenuItem}
23 TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem})
24 private
25 FIgnoreMenuChanged: Boolean;
26 FCaption: WideString;
27 FHint: WideString;
28 FKeyboardLayout: HKL;
29 function GetCaption: WideString;
30 procedure SetInheritedCaption(const Value: AnsiString);
31 procedure SetCaption(const Value: WideString);
32 function IsCaptionStored: Boolean;
33 procedure UpdateMenuString(ParentMenu: TMenu);
34 function GetAlignmentDrawStyle: Word;
35 function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
36 function GetHint: WideString;
37 procedure SetInheritedHint(const Value: AnsiString);
38 procedure SetHint(const Value: WideString);
39 function IsHintStored: Boolean;
40 protected
41 procedure DefineProperties(Filer: TFiler); override;
42 function GetActionLinkClass: TMenuActionLinkClass; override;
43 procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
44 procedure MenuChanged(Rebuild: Boolean); override;
45 procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
46 State: TOwnerDrawState; TopLevel: Boolean); override;
47 procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
48 var Rect: TRect; Selected: Boolean; Flags: Integer);
49 procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override;
50 public
51 procedure InitiateAction; override;
52 procedure Loaded; override;
53 function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
54 published
55 property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored;
56 property Hint: WideString read GetHint write SetHint stored IsHintStored;
57 end;
58
59{TNT-WARN TMainMenu}
60 TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu})
61 protected
62 procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
63 public
64 {$IFDEF COMPILER_9_UP}
65 function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
66 {$ENDIF}
67 end;
68
69{TNT-WARN TPopupMenu}
70 TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu})
71 protected
72 procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
73 public
74 constructor Create(AOwner: TComponent); override;
75 {$IFDEF COMPILER_9_UP}
76 function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
77 {$ENDIF}
78 destructor Destroy; override;
79 procedure Popup(X, Y: Integer); override;
80 end;
81
82{TNT-WARN NewSubMenu}
83function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
84 const AName: TComponentName; const Items: array of TTntMenuItem;
85 AEnabled: Boolean): TTntMenuItem;
86{TNT-WARN NewItem}
87function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
88 AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
89 const AName: TComponentName): TTntMenuItem;
90
91function MessageToShortCut(Msg: TWMKeyDown): TShortCut;
92
93{TNT-WARN ShortCutToText}
94function WideShortCutToText(WordShortCut: Word): WideString;
95{TNT-WARN TextToShortCut}
96function WideTextToShortCut(Text: WideString): TShortCut;
97{TNT-WARN GetHotKey}
98function WideGetHotkey(const Text: WideString): WideString;
99{TNT-WARN StripHotkey}
100function WideStripHotkey(const Text: WideString): WideString;
101{TNT-WARN AnsiSameCaption}
102function WideSameCaption(const Text1, Text2: WideString): Boolean;
103
104function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
105function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
106
107procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
108
109procedure FixMenuBiDiProblem(Menu: TMenu);
110
111function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
112
113type
114 TTntPopupList = class(TPopupList)
115 private
116 SavedPopupList: TPopupList;
117 protected
118 procedure WndProc(var Message: TMessage); override;
119 end;
120
121var
122 TntPopupList: TTntPopupList;
123
124implementation
125
126uses
127 Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics,
128 TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows;
129
130function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
131 const AName: TComponentName; const Items: array of TTntMenuItem;
132 AEnabled: Boolean): TTntMenuItem;
133var
134 I: Integer;
135begin
136 Result := TTntMenuItem.Create(nil);
137 for I := Low(Items) to High(Items) do
138 Result.Add(Items[I]);
139 Result.Caption := ACaption;
140 Result.HelpContext := hCtx;
141 Result.Name := AName;
142 Result.Enabled := AEnabled;
143end;
144
145function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
146 AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
147 const AName: TComponentName): TTntMenuItem;
148begin
149 Result := TTntMenuItem.Create(nil);
150 with Result do
151 begin
152 Caption := ACaption;
153 ShortCut := AShortCut;
154 OnClick := AOnClick;
155 HelpContext := hCtx;
156 Checked := AChecked;
157 Enabled := AEnabled;
158 Name := AName;
159 end;
160end;
161
162function MessageToShortCut(Msg: TWMKeyDown): TShortCut;
163var
164 ShiftState: TShiftState;
165begin
166 ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData);
167 Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState);
168end;
169
170function WideGetSpecialName(WordShortCut: Word): WideString;
171var
172 ScanCode: Integer;
173 KeyName: array[0..255] of WideChar;
174begin
175 Assert(Win32PlatformIsUnicode);
176 Result := '';
177 ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16;
178 if ScanCode <> 0 then
179 begin
180 GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName));
181 Result := KeyName;
182 end;
183end;
184
185function WideGetKeyboardChar(Key: Word): WideChar;
186var
187 LatinNumChar: WideChar;
188begin
189 Assert(Win32PlatformIsUnicode);
190 Result := WideChar(MapVirtualKeyW(Key, 2));
191 if (Key in [$30..$39]) then
192 begin
193 // Check to see if "0" - "9" can be used if all that differs is shift state
194 LatinNumChar := WideChar(Key - $30 + Ord('0'));
195 if (Result <> LatinNumChar)
196 and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then // .Hi would be the shift state
197 Result := LatinNumChar;
198 end;
199end;
200
201function WideShortCutToText(WordShortCut: Word): WideString;
202var
203 Name: WideString;
204begin
205 if (not Win32PlatformIsUnicode)
206 or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav},
207 $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}])
208 then
209 Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut)
210 else begin
211 case WordRec(WordShortCut).Lo of
212 $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0}
213 $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z}
214 $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0}
215 else
216 Name := WideGetSpecialName(WordShortCut);
217 end;
218 if Name <> '' then
219 begin
220 Result := '';
221 if WordShortCut and scShift <> 0 then Result := Result + SmkcShift;
222 if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl;
223 if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt;
224 Result := Result + Name;
225 end
226 else Result := '';
227 end;
228end;
229
230{ This function is *very* slow. Use sparingly. Return 0 if no VK code was
231 found for the text }
232
233function WideTextToShortCut(Text: WideString): TShortCut;
234
235 { If the front of Text is equal to Front then remove the matching piece
236 from Text and return True, otherwise return False }
237
238 function CompareFront(var Text: WideString; const Front: WideString): Boolean;
239 begin
240 Result := (Pos(Front, Text) = 1);
241 if Result then
242 Delete(Text, 1, Length(Front));
243 end;
244
245var
246 Key: TShortCut;
247 Shift: TShortCut;
248begin
249 Result := 0;
250 Shift := 0;
251 while True do
252 begin
253 if CompareFront(Text, SmkcShift) then Shift := Shift or scShift
254 else if CompareFront(Text, '^') then Shift := Shift or scCtrl
255 else if CompareFront(Text, SmkcCtrl) then Shift := Shift or scCtrl
256 else if CompareFront(Text, SmkcAlt) then Shift := Shift or scAlt
257 else Break;
258 end;
259 if Text = '' then Exit;
260 for Key := $08 to $255 do { Copy range from table in ShortCutToText }
261 if WideSameText(Text, WideShortCutToText(Key)) then
262 begin
263 Result := Key or Shift;
264 Exit;
265 end;
266end;
267
268function WideGetHotkeyPos(const Text: WideString): Integer;
269var
270 I, L: Integer;
271begin
272 Result := 0;
273 I := 1;
274 L := Length(Text);
275 while I <= L do
276 begin
277 if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then
278 begin
279 Inc(I);
280 if Text[I] <> cHotkeyPrefix then
281 Result := I; // this might not be the last
282 end;
283 Inc(I);
284 end;
285end;
286
287function WideGetHotkey(const Text: WideString): WideString;
288var
289 I: Integer;
290begin
291 I := WideGetHotkeyPos(Text);
292 if I = 0 then
293 Result := ''
294 else
295 Result := Text[I];
296end;
297
298function WideStripHotkey(const Text: WideString): WideString;
299var
300 I: Integer;
301begin
302 Result := Text;
303 I := 1;
304 while I <= Length(Result) do
305 begin
306 if Result[I] = cHotkeyPrefix then
307 if SysLocale.FarEast
308 and ((I > 1) and (Length(Result) - I >= 2)
309 and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin
310 Delete(Result, I - 1, 4);
311 Dec(I, 2);
312 end else
313 Delete(Result, I, 1);
314 Inc(I);
315 end;
316end;
317
318function WideSameCaption(const Text1, Text2: WideString): Boolean;
319begin
320 Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2));
321end;
322
323function WideSameCaptionStr(const Text1, Text2: WideString): Boolean;
324begin
325 Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2));
326end;
327
328function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
329begin
330 if MenuItem is TTntMenuItem then
331 Result := TTntMenuItem(MenuItem).Caption
332 else
333 Result := MenuItem.Caption;
334end;
335
336function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
337begin
338 if MenuItem is TTntMenuItem then
339 Result := TTntMenuItem(MenuItem).Hint
340 else
341 Result := MenuItem.Hint;
342end;
343
344procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
345{If top-level items are created as owner-drawn, they will not appear as raised
346buttons when the mouse hovers over them. The VCL will often create top-level
347items as owner-drawn even when they don't need to be (owner-drawn state can be
348set on an item-by-item basis). This routine turns off the owner-drawn flag for
349top-level items if it appears unnecessary}
350
351 function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean;
352 var
353 Images: TCustomImageList;
354 begin
355 Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil');
356 Images := Item.GetImageList;
357 Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count))
358 or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty))
359 end;
360
361var
362 HM: HMenu;
363 i: integer;
364 Info: TMenuItemInfoA;
365 Item: TMenuItem{TNT-ALLOW TMenuItem};
366 Win98Plus: boolean;
367begin
368 if Assigned(Menu) then begin
369 Win98Plus:= (Win32MajorVersion > 4)
370 or((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
371 if not Win98Plus then
372 Exit; {exit if Windows 95 or NT 4.0}
373 HM:= Menu.Handle;
374 Info.cbSize:= sizeof(Info);
375 for i := 0 to GetMenuItemCount(HM) - 1 do begin
376 Info.fMask:= MIIM_FTYPE or MIIM_ID;
377 if not GetMenuItemInfo(HM, i, true, Info) then
378 Break;
379 if Info.fType and MFT_OWNERDRAW <> 0 then begin
380 Item:= Menu.FindItem(Info.wID, fkCommand);
381 if not Assigned(Item) then
382 continue;
383 if Assigned(Item.OnDrawItem)
384 or Assigned(Item.OnAdvancedDrawItem)
385 or ItemHasValidImage(Item) then
386 Continue;
387 Info.fMask:= MIIM_FTYPE or MIIM_STRING;
388 Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING;
389 if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin
390 // Unicode
391 TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption);
392 SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info));
393 end else begin
394 // Ansi
395 Info.dwTypeData:= PAnsiChar(Item.Caption);
396 SetMenuItemInfoA(HM, i, true, Info);
397 end;
398 end;
399 end;
400 end;
401end;
402
403{ TTntMenuItem's utility procs }
404
405procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString);
406var
407 I: Integer;
408 FarEastHotString: WideString;
409begin
410 if (AnsiString(Source) <> AnsiString(Dest))
411 and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin
412 // when reduced to ansi, the only difference is hot key positions
413 Dest := WideStripHotkey(Dest);
414 I := 1;
415 while I <= Length(Source) do
416 begin
417 if Source[I] = cHotkeyPrefix then begin
418 if SysLocale.FarEast
419 and ((I > 1) and (Length(Source) - I >= 2)
420 and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin
421 FarEastHotString := Copy(Source, I - 1, 4);
422 Dec(I);
423 Insert(FarEastHotString, Dest, I);
424 Inc(I, 3);
425 end else begin
426 Insert(cHotkeyPrefix, Dest, I);
427 Inc(I);
428 end;
429 end;
430 Inc(I);
431 end;
432 // test work
433 if AnsiString(Source) <> AnsiString(Dest) then
434 raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").',
435 [AnsiString(Source), AnsiString(Dest)]);
436 end;
437end;
438
439procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu);
440var
441 i: integer;
442begin
443 if (Items.ComponentState * [csReading, csDestroying] = []) then begin
444 for i := Items.Count - 1 downto 0 do
445 UpdateMenuItems(Items[i], ParentMenu);
446 if Items is TTntMenuItem then
447 TTntMenuItem(Items).UpdateMenuString(ParentMenu);
448 end;
449end;
450
451procedure FixMenuBiDiProblem(Menu: TMenu);
452var
453 i: integer;
454begin
455 // TMenu sometimes sets bidi on first visible item which can convert caption to ansi
456 if (SysLocale.MiddleEast)
457 and (Menu <> nil)
458 and (Menu.Items.Count > 0) then
459 begin
460 for i := 0 to Menu.Items.Count - 1 do begin
461 if Menu.Items[i].Visible then begin
462 if (Menu.Items[i] is TTntMenuItem) then
463 (Menu.Items[i] as TTntMenuItem).UpdateMenuString(Menu);
464 break; // found first visible menu item!
465 end;
466 end;
467 end;
468end;
469
470
471{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6
472type
473 THackMenuItem = class(TComponent)
474 protected
475 FxxxxCaption: Ansistring;
476 FxxxxHandle: HMENU;
477 FxxxxChecked: Boolean;
478 FxxxxEnabled: Boolean;
479 FxxxxDefault: Boolean;
480 FxxxxAutoHotkeys: TMenuItemAutoFlag;
481 FxxxxAutoLineReduction: TMenuItemAutoFlag;
482 FxxxxRadioItem: Boolean;
483 FxxxxVisible: Boolean;
484 FxxxxGroupIndex: Byte;
485 FxxxxImageIndex: TImageIndex;
486 FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
487 FxxxxBreak: TMenuBreak;
488 FBitmap: TBitmap;
489 FxxxxCommand: Word;
490 FxxxxHelpContext: THelpContext;
491 FxxxxHint: AnsiString;
492 FxxxxItems: TList;
493 FxxxxShortCut: TShortCut;
494 FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
495 FMerged: TMenuItem{TNT-ALLOW TMenuItem};
496 FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
497 end;
498{$ENDIF}
499{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7
500type
501 THackMenuItem = class(TComponent)
502 protected
503 FxxxxCaption: AnsiString;
504 FxxxxHandle: HMENU;
505 FxxxxChecked: Boolean;
506 FxxxxEnabled: Boolean;
507 FxxxxDefault: Boolean;
508 FxxxxAutoHotkeys: TMenuItemAutoFlag;
509 FxxxxAutoLineReduction: TMenuItemAutoFlag;
510 FxxxxRadioItem: Boolean;
511 FxxxxVisible: Boolean;
512 FxxxxGroupIndex: Byte;
513 FxxxxImageIndex: TImageIndex;
514 FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
515 FxxxxBreak: TMenuBreak;
516 FBitmap: TBitmap;
517 FxxxxCommand: Word;
518 FxxxxHelpContext: THelpContext;
519 FxxxxHint: AnsiString;
520 FxxxxItems: TList;
521 FxxxxShortCut: TShortCut;
522 FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
523 FMerged: TMenuItem{TNT-ALLOW TMenuItem};
524 FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
525 end;
526{$ENDIF}
527{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9
528type
529 THackMenuItem = class(TComponent)
530 protected
531 FxxxxCaption: AnsiString;
532 FxxxxHandle: HMENU;
533 FxxxxChecked: Boolean;
534 FxxxxEnabled: Boolean;
535 FxxxxDefault: Boolean;
536 FxxxxAutoHotkeys: TMenuItemAutoFlag;
537 FxxxxAutoLineReduction: TMenuItemAutoFlag;
538 FxxxxRadioItem: Boolean;
539 FxxxxVisible: Boolean;
540 FxxxxGroupIndex: Byte;
541 FxxxxImageIndex: TImageIndex;
542 FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
543 FxxxxBreak: TMenuBreak;
544 FBitmap: TBitmap;
545 FxxxxCommand: Word;
546 FxxxxHelpContext: THelpContext;
547 FxxxxHint: AnsiString;
548 FxxxxItems: TList;
549 FxxxxShortCut: TShortCut;
550 FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
551 FMerged: TMenuItem{TNT-ALLOW TMenuItem};
552 FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
553 end;
554{$ENDIF}
555{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10
556type
557 THackMenuItem = class(TComponent)
558 protected
559 FxxxxCaption: AnsiString;
560 FxxxxHandle: HMENU;
561 FxxxxChecked: Boolean;
562 FxxxxEnabled: Boolean;
563 FxxxxDefault: Boolean;
564 FxxxxAutoHotkeys: TMenuItemAutoFlag;
565 FxxxxAutoLineReduction: TMenuItemAutoFlag;
566 FxxxxRadioItem: Boolean;
567 FxxxxVisible: Boolean;
568 FxxxxGroupIndex: Byte;
569 FxxxxImageIndex: TImageIndex;
570 FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
571 FxxxxBreak: TMenuBreak;
572 FBitmap: TBitmap;
573 FxxxxCommand: Word;
574 FxxxxHelpContext: THelpContext;
575 FxxxxHint: AnsiString;
576 FxxxxItems: TList;
577 FxxxxShortCut: TShortCut;
578 FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
579 FMerged: TMenuItem{TNT-ALLOW TMenuItem};
580 FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
581 end;
582{$ENDIF}
583
584function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
585begin
586 Result := Assigned(THackMenuItem(MenuItem).FBitmap);
587end;
588
589{ TTntMenuItem }
590
591procedure TTntMenuItem.DefineProperties(Filer: TFiler);
592begin
593 inherited;
594 TntPersistent_AfterInherited_DefineProperties(Filer, Self);
595end;
596
597type TAccessActionlink = class(TActionLink);
598
599procedure TTntMenuItem.InitiateAction;
600begin
601 if GetKeyboardLayout(0) <> FKeyboardLayout then
602 MenuChanged(False);
603 inherited;
604end;
605
606function TTntMenuItem.IsCaptionStored: Boolean;
607begin
608 Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked);
609end;
610
611procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString);
612begin
613 inherited Caption := Value;
614end;
615
616function TTntMenuItem.GetCaption: WideString;
617begin
618 if (AnsiString(FCaption) <> inherited Caption)
619 and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then
620 begin
621 // only difference is hotkey position, update caption with new hotkey position
622 SyncHotKeyPosition(inherited Caption, FCaption);
623 end;
624 Result := GetSyncedWideString(FCaption, (inherited Caption));
625end;
626
627procedure TTntMenuItem.SetCaption(const Value: WideString);
628begin
629 GetCaption; // auto adjust for hot key changes
630 SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption);
631end;
632
633function TTntMenuItem.GetHint: WideString;
634begin
635 Result := GetSyncedWideString(FHint, inherited Hint);
636end;
637
638procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString);
639begin
640 inherited Hint := Value;
641end;
642
643procedure TTntMenuItem.SetHint(const Value: WideString);
644begin
645 SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint);
646end;
647
648function TTntMenuItem.IsHintStored: Boolean;
649begin
650 Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked;
651end;
652
653procedure TTntMenuItem.Loaded;
654begin
655 inherited;
656 UpdateMenuString(GetParentMenu);
657end;
658
659procedure TTntMenuItem.MenuChanged(Rebuild: Boolean);
660begin
661 if (not FIgnoreMenuChanged) then begin
662 inherited;
663 UpdateMenuItems(Self, GetParentMenu);
664 FixMenuBiDiProblem(GetParentMenu);
665 end;
666end;
667
668procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu);
669var
670 ParentHandle: THandle;
671
672 function NativeMenuTypeIsString: Boolean;
673 var
674 MenuItemInfo: TMenuItemInfoW;
675 Buffer: array[0..79] of WideChar;
676 begin
677 MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
678 MenuItemInfo.fMask := MIIM_TYPE;
679 MenuItemInfo.dwTypeData := Buffer; // ??
680 MenuItemInfo.cch := Length(Buffer); // ??
681 Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
682 and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0)
683 end;
684
685 function NativeMenuString: WideString;
686 var
687 Len: Integer;
688 begin
689 Assert(Win32PlatformIsUnicode);
690 Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND);
691 if Len = 0 then
692 Result := ''
693 else begin
694 SetLength(Result, Len + 1);
695 Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND);
696 SetLength(Result, Len);
697 end;
698 end;
699
700 procedure SetMenuString(const Value: WideString);
701 var
702 MenuItemInfo: TMenuItemInfoW;
703 Buffer: array[0..79] of WideChar;
704 begin
705 MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
706 MenuItemInfo.fMask := MIIM_TYPE;
707 MenuItemInfo.dwTypeData := Buffer; // ??
708 MenuItemInfo.cch := Length(Buffer); // ??
709 if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
710 and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then
711 begin
712 MenuItemInfo.dwTypeData := PWideChar(Value);
713 MenuItemInfo.cch := Length(Value);
714 Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo));
715 end;
716 end;
717
718 function SameEvent(A, B: TMenuMeasureItemEvent): Boolean;
719 begin
720 Result := @A = @B;
721 end;
722
723var
724 MenuCaption: WideString;
725begin
726 FKeyboardLayout := GetKeyboardLayout(0);
727 if Parent = nil then
728 ParentHandle := 0
729 else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then
730 ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle
731 else
732 ParentHandle := Parent.Handle;
733
734 if (Win32PlatformIsUnicode)
735 and (Parent <> nil) and (ParentMenu <> nil)
736 and (ComponentState * [csReading, csDestroying] = [])
737 and (Visible)
738 and (NativeMenuTypeIsString) then begin
739 MenuCaption := Caption;
740 if (Count = 0)
741 and ((ShortCut <> scNone)
742 and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then
743 MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut);
744 if (NativeMenuString <> MenuCaption) then
745 begin
746 SetMenuString(MenuCaption);
747 if ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil))
748 and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu})
749 and (ParentMenu.WindowHandle <> 0) then
750 DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items}
751 end;
752 end;
753end;
754
755function TTntMenuItem.GetAlignmentDrawStyle: Word;
756const
757 Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
758var
759 ParentMenu: TMenu;
760 Alignment: TPopupAlignment;
761begin
762 ParentMenu := GetParentMenu;
763 if ParentMenu is TMenu then
764 Alignment := paLeft
765 else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then
766 Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment
767 else
768 Alignment := paLeft;
769 Result := Alignments[Alignment];
770end;
771
772procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
773 State: TOwnerDrawState; TopLevel: Boolean);
774
775 procedure DrawMenuText(BiDi: Boolean);
776 var
777 ImageList: TCustomImageList;
778 DrawImage, DrawGlyph: Boolean;
779 GlyphRect, SaveRect: TRect;
780 DrawStyle: Longint;
781 Selected: Boolean;
782 Win98Plus: Boolean;
783 Win2K: Boolean;
784 begin
785 ImageList := GetImageList;
786 Selected := odSelected in State;
787 Win98Plus := (Win32MajorVersion > 4) or
788 ((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
789 Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT);
790 with ACanvas do
791 begin
792 GlyphRect.Left := ARect.Left + 1;
793 DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and
794 (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or
795 Bitmap.Empty));
796 if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then
797 begin
798 DrawGlyph := True;
799 if DrawImage then
800 GlyphRect.Right := GlyphRect.Left + ImageList.Width
801 else begin
802 { Need to add BitmapWidth/Height properties for TMenuItem if we're to
803 support them. Right now let's hardcode them to 16x16. }
804 GlyphRect.Right := GlyphRect.Left + 16;
805 end;
806 { Draw background pattern brush if selected }
807 if Checked then
808 begin
809 Inc(GlyphRect.Right);
810 if not Selected then
811 Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
812 Inc(GlyphRect.Left);
813 end;
814 if Checked then
815 Dec(GlyphRect.Right);
816 end else begin
817 if (ImageList <> nil) and (not TopLevel) then
818 GlyphRect.Right := GlyphRect.Left + ImageList.Width
819 else
820 GlyphRect.Right := GlyphRect.Left;
821 DrawGlyph := False;
822 end;
823 if BiDi then begin
824 SaveRect := GlyphRect;
825 GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left);
826 GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left);
827 end;
828 with GlyphRect do begin
829 Dec(Left);
830 Inc(Right, 2);
831 end;
832 if Selected then begin
833 if DrawGlyph then begin
834 if BiDi then
835 ARect.Right := GlyphRect.Left - 1
836 else
837 ARect.Left := GlyphRect.Right + 1;
838 end;
839 if not (Win98Plus and TopLevel) then
840 Brush.Color := clHighlight;
841 end;
842 if TopLevel and Win98Plus and (not Selected)
843 {$IFDEF COMPILER_7_UP}
844 and (not Win32PlatformIsXP)
845 {$ENDIF}
846 then
847 OffsetRect(ARect, 0, -1);
848 if not (Selected and DrawGlyph) then begin
849 if BiDi then
850 ARect.Right := GlyphRect.Left - 1
851 else
852 ARect.Left := GlyphRect.Right + 1;
853 end;
854 Inc(ARect.Left, 2);
855 Dec(ARect.Right, 1);
856 DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle;
857 if Win2K and (odNoAccel in State) then
858 DrawStyle := DrawStyle or DT_HIDEPREFIX;
859 { Calculate vertical layout }
860 SaveRect := ARect;
861 if odDefault in State then
862 Font.Style := [fsBold];
863 DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP);
864 if BiDi then begin
865 { the DT_CALCRECT does not take into account alignment }
866 ARect.Left := SaveRect.Left;
867 ARect.Right := SaveRect.Right;
868 end;
869 OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2);
870 if TopLevel and Selected and Win98Plus
871 {$IFDEF COMPILER_7_UP}
872 and (not Win32PlatformIsXP)
873 {$ENDIF}
874 then
875 OffsetRect(ARect, 1, 0);
876 DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle);
877 if (ShortCut <> scNone) and not TopLevel then
878 begin
879 if BiDi then begin
880 ARect.Left := 10;
881 ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut));
882 end else begin
883 ARect.Left := ARect.Right;
884 ARect.Right := SaveRect.Right - 10;
885 end;
886 DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT);
887 end;
888 end;
889 end;
890
891var
892 ParentMenu: TMenu;
893 SaveCaption: WideString;
894 SaveShortCut: TShortCut;
895begin
896 ParentMenu := GetParentMenu;
897 if (not Win32PlatformIsUnicode)
898 or (Self.IsLine)
899 or ( (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil))
900 and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem)) ) then
901 inherited
902 else begin
903 SaveCaption := Caption;
904 SaveShortCut := ShortCut;
905 try
906 FIgnoreMenuChanged := True;
907 try
908 Caption := '';
909 ShortCut := scNone;
910 finally
911 FIgnoreMenuChanged := False;
912 end;
913 inherited;
914 finally
915 FIgnoreMenuChanged := True;
916 try
917 Caption := SaveCaption;
918 ShortCut := SaveShortcut;
919 finally
920 FIgnoreMenuChanged := False;
921 end;
922 end;
923 DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft))
924 end;
925end;
926
927procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
928 var Rect: TRect; Selected: Boolean; Flags: Longint);
929var
930 Text: WideString;
931 ParentMenu: TMenu;
932begin
933 if (not Win32PlatformIsUnicode)
934 or (IsLine) then
935 inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags)
936 else begin
937 ParentMenu := GetParentMenu;
938 if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then
939 begin
940 if Flags and DT_LEFT = DT_LEFT then
941 Flags := Flags and (not DT_LEFT) or DT_RIGHT
942 else if Flags and DT_RIGHT = DT_RIGHT then
943 Flags := Flags and (not DT_RIGHT) or DT_LEFT;
944 Flags := Flags or DT_RTLREADING;
945 end;
946 Text := ACaption;
947 if (Flags and DT_CALCRECT <> 0) and ((Text = '') or
948 (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' ';
949 with ACanvas do
950 begin
951 Brush.Style := bsClear;
952 if Default then
953 Font.Style := Font.Style + [fsBold];
954 if not Enabled then
955 begin
956 if not Selected then
957 begin
958 OffsetRect(Rect, 1, 1);
959 Font.Color := clBtnHighlight;
960 Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
961 OffsetRect(Rect, -1, -1);
962 end;
963 if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then
964 Font.Color := clBtnHighlight else
965 Font.Color := clBtnShadow;
966 end;
967 Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
968 end;
969 end;
970end;
971
972function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
973var
974 R: TRect;
975begin
976 FillChar(R, SizeOf(R), 0);
977 DoDrawText(ACanvas, Text, R, False,
978 GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT);
979 Result := R.Right - R.Left;
980end;
981
982procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer);
983var
984 SaveMeasureItemEvent: TMenuMeasureItemEvent;
985begin
986 if (not Win32PlatformIsUnicode)
987 or (Self.IsLine) then
988 inherited
989 else begin
990 SaveMeasureItemEvent := inherited OnMeasureItem;
991 try
992 inherited OnMeasureItem := nil;
993 inherited;
994 Inc(Width, MeasureItemTextWidth(ACanvas, Caption));
995 Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption));
996 if ShortCut <> scNone then begin
997 Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut)));
998 Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)));
999 end;
1000 finally
1001 inherited OnMeasureItem := SaveMeasureItemEvent;
1002 end;
1003 if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height);
1004 end;
1005end;
1006
1007function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
1008var
1009 I: Integer;
1010begin
1011 Result := nil;
1012 ACaption := WideStripHotkey(ACaption);
1013 for I := 0 to Count - 1 do
1014 if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then
1015 begin
1016 Result := Items[I];
1017 System.Break;
1018 end;
1019end;
1020
1021function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass;
1022begin
1023 Result := TTntMenuActionLink;
1024end;
1025
1026procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean);
1027begin
1028 if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin
1029 if not CheckDefaults or (Caption = '') then
1030 Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
1031 if not CheckDefaults or (Hint = '') then
1032 Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
1033 end;
1034 inherited;
1035end;
1036
1037{ TTntMainMenu }
1038
1039{$IFDEF COMPILER_9_UP}
1040function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1041begin
1042 Result := TTntMenuItem.Create(Self);
1043end;
1044{$ENDIF}
1045
1046procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
1047begin
1048 inherited;
1049 UpdateMenuItems(Items, Self);
1050 if (THackMenuItem(Items).FMerged <> nil) then begin
1051 UpdateMenuItems(THackMenuItem(Items).FMerged, Self);
1052 end;
1053end;
1054
1055{ TTntPopupMenu }
1056
1057constructor TTntPopupMenu.Create(AOwner: TComponent);
1058begin
1059 inherited;
1060 PopupList.Remove(Self);
1061 if TntPopupList <> nil then
1062 TntPopupList.Add(Self);
1063end;
1064
1065{$IFDEF COMPILER_9_UP}
1066function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1067begin
1068 Result := TTntMenuItem.Create(Self);
1069end;
1070{$ENDIF}
1071
1072destructor TTntPopupMenu.Destroy;
1073begin
1074 if TntPopupList <> nil then
1075 TntPopupList.Remove(Self);
1076 PopupList.Add(Self);
1077 inherited;
1078end;
1079
1080procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
1081begin
1082 inherited;
1083 UpdateMenuItems(Items, Self);
1084end;
1085
1086procedure TTntPopupMenu.Popup(X, Y: Integer);
1087begin
1088 Menus.PopupList := TntPopupList;
1089 try
1090 inherited;
1091 finally
1092 Menus.PopupList := TntPopupList.SavedPopupList;
1093 end;
1094end;
1095
1096{ TTntPopupList }
1097
1098procedure TTntPopupList.WndProc(var Message: TMessage);
1099var
1100 I, Item: Integer;
1101 MenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1102 FindKind: TFindItemKind;
1103begin
1104 case Message.Msg of
1105 WM_ENTERMENULOOP:
1106 begin
1107 Menus.PopupList := SavedPopupList;
1108 for i := 0 to Count - 1 do
1109 FixMenuBiDiProblem(Items[i]);
1110 end;
1111 WM_MENUSELECT:
1112 with TWMMenuSelect(Message) do
1113 begin
1114 FindKind := fkCommand;
1115 if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
1116 for I := 0 to Count - 1 do
1117 begin
1118 if FindKind = fkHandle then
1119 begin
1120 if Menu <> 0 then
1121 Item := Integer(GetSubMenu(Menu, IDItem)) else
1122 Item := -1;
1123 end
1124 else
1125 Item := IDItem;
1126 MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind);
1127 if MenuItem <> nil then
1128 begin
1129 TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem));
1130 Exit;
1131 end;
1132 end;
1133 TntApplication.Hint := '';
1134 end;
1135 end;
1136 inherited;
1137end;
1138
1139initialization
1140 TntPopupList := TTntPopupList.Create;
1141 TntPopupList.SavedPopupList := Menus.PopupList;
1142
1143finalization
1144 FreeAndNil(TntPopupList);
1145
1146end.
Note: See TracBrowser for help on using the repository browser.