tntmenus.pas

TNT Components Source

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.3.0                                                       }
{                                                                             }
{    Copyright (c) 2002-2007, Troy Wolbrink ([e-mail])       }
{                                                                             }
{*****************************************************************************}

unit TntMenus;

{$INCLUDE TntCompilers.inc}

interface

uses
  Windows, Classes, Menus, Graphics, Messages;

type
{TNT-WARN TMenuItem}
  TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem})
  private
    FIgnoreMenuChanged: Boolean;
    FCaption: WideString;
    FHint: WideString;
    FKeyboardLayout: HKL;
    function GetCaption: WideString;
    procedure SetInheritedCaption(const Value: AnsiString);
    procedure SetCaption(const Value: WideString);
    function IsCaptionStored: Boolean;
    procedure UpdateMenuString(ParentMenu: TMenu);
    function GetAlignmentDrawStyle: Word;
    function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
    function GetHint: WideString;
    procedure SetInheritedHint(const Value: AnsiString);
    procedure SetHint(const Value: WideString);
    function IsHintStored: Boolean;
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function GetActionLinkClass: TMenuActionLinkClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure MenuChanged(Rebuild: Boolean); override;
    procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
      State: TOwnerDrawState; TopLevel: Boolean); override;
    procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
      var Rect: TRect; Selected: Boolean; Flags: Integer);
    procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override; 
  public
    procedure InitiateAction; override;
    procedure Loaded; override;
    function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
  published
    property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored;
    property Hint: WideString read GetHint write SetHint stored IsHintStored;
  end;

{TNT-WARN TMainMenu}
  TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu})
  protected
    procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
  public
    {$IFDEF COMPILER_9_UP}
    function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
    {$ENDIF}
  end;

{TNT-WARN TPopupMenu}
  TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu})
  protected
    procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    {$IFDEF COMPILER_9_UP}
    function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
    {$ENDIF}
    destructor Destroy; override;
    procedure Popup(X, Y: Integer); override;
  end;

{TNT-WARN NewSubMenu}
function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
  const AName: TComponentName; const Items: array of TTntMenuItem;
    AEnabled: Boolean): TTntMenuItem;
{TNT-WARN NewItem}
function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
    const AName: TComponentName): TTntMenuItem;

function MessageToShortCut(Msg: TWMKeyDown): TShortCut;

{TNT-WARN ShortCutToText}
function WideShortCutToText(WordShortCut: Word): WideString;
{TNT-WARN TextToShortCut}
function WideTextToShortCut(Text: WideString): TShortCut;
{TNT-WARN GetHotKey}
function WideGetHotkey(const Text: WideString): WideString;
{TNT-WARN StripHotkey}
function WideStripHotkey(const Text: WideString): WideString;
{TNT-WARN AnsiSameCaption}
function WideSameCaption(const Text1, Text2: WideString): Boolean;

function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;

procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});

procedure FixMenuBiDiProblem(Menu: TMenu);

function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;

type
  TTntPopupList = class(TPopupList)
  private
    SavedPopupList: TPopupList;
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

var
  TntPopupList: TTntPopupList;

implementation

uses
  Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics,
  TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows;

function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
  const AName: TComponentName; const Items: array of TTntMenuItem;
    AEnabled: Boolean): TTntMenuItem;
var
  I: Integer;
begin
  Result := TTntMenuItem.Create(nil);
  for I := Low(Items) to High(Items) do
    Result.Add(Items[I]);
  Result.Caption := ACaption;
  Result.HelpContext := hCtx;
  Result.Name := AName;
  Result.Enabled := AEnabled;
end;

function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
    const AName: TComponentName): TTntMenuItem;
begin
  Result := TTntMenuItem.Create(nil);
  with Result do
  begin
    Caption := ACaption;
    ShortCut := AShortCut;
    OnClick := AOnClick;
    HelpContext := hCtx;
    Checked := AChecked;
    Enabled := AEnabled;
    Name := AName;
  end;
end;

function MessageToShortCut(Msg: TWMKeyDown): TShortCut;
var
  ShiftState: TShiftState;
begin
  ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData);
  Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState);
end;

function WideGetSpecialName(WordShortCut: Word): WideString;
var
  ScanCode: Integer;
  KeyName: array[0..255] of WideChar;
begin
  Assert(Win32PlatformIsUnicode);
  Result := '';
  ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16;
  if ScanCode <> 0 then
  begin
    GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName));
    Result := KeyName;
  end;
end;

function WideGetKeyboardChar(Key: Word): WideChar;
var
  LatinNumChar: WideChar;
begin
  Assert(Win32PlatformIsUnicode);
  Result := WideChar(MapVirtualKeyW(Key, 2));
  if (Key in [$30..$39]) then
  begin
    // Check to see if "0" - "9" can be used if all that differs is shift state
    LatinNumChar := WideChar(Key - $30 + Ord('0'));
    if (Result <> LatinNumChar)
    and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then  // .Hi would be the shift state
      Result := LatinNumChar;
  end;
end;

function WideShortCutToText(WordShortCut: Word): WideString;
var
  Name: WideString;
begin
  if (not Win32PlatformIsUnicode)
  or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav},
                               $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}])
  then
    Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut)
  else begin
    case WordRec(WordShortCut).Lo of
      $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0}
      $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z}
      $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0}
    else
      Name := WideGetSpecialName(WordShortCut);
    end;
    if Name <> '' then
    begin
      Result := '';
      if WordShortCut and scShift <> 0 then Result := Result + SmkcShift;
      if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl;
      if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt;
      Result := Result + Name;
    end
    else Result := '';
  end;
end;

{ This function is *very* slow.  Use sparingly.  Return 0 if no VK code was
  found for the text }

function WideTextToShortCut(Text: WideString): TShortCut;

  { If the front of Text is equal to Front then remove the matching piece
    from Text and return True, otherwise return False }

  function CompareFront(var Text: WideString; const Front: WideString): Boolean;
  begin
    Result := (Pos(Front, Text) = 1);
    if Result then
      Delete(Text, 1, Length(Front));
  end;

var
  Key: TShortCut;
  Shift: TShortCut;
begin
  Result := 0;
  Shift := 0;
  while True do
  begin
    if      CompareFront(Text, SmkcShift) then Shift := Shift or scShift
    else if CompareFront(Text, '^')       then Shift := Shift or scCtrl
    else if CompareFront(Text, SmkcCtrl)  then Shift := Shift or scCtrl
    else if CompareFront(Text, SmkcAlt)   then Shift := Shift or scAlt
    else Break;
  end;
  if Text = '' then Exit;
  for Key := $08 to $255 do { Copy range from table in ShortCutToText }
    if WideSameText(Text, WideShortCutToText(Key)) then
    begin
      Result := Key or Shift;
      Exit;
    end;
end;

function WideGetHotkeyPos(const Text: WideString): Integer;
var
  I, L: Integer;
begin
  Result := 0;
  I := 1;
  L := Length(Text);
  while I <= L do
  begin
    if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then
    begin
      Inc(I);
      if Text[I] <> cHotkeyPrefix then
        Result := I; // this might not be the last
    end;
    Inc(I);
  end;
end;

function WideGetHotkey(const Text: WideString): WideString;
var
  I: Integer;
begin
  I := WideGetHotkeyPos(Text);
  if I = 0 then
    Result := ''
  else
    Result := Text[I];
end;

function WideStripHotkey(const Text: WideString): WideString;
var
  I: Integer;
begin
  Result := Text;
  I := 1;
  while I <= Length(Result) do
  begin
    if Result[I] = cHotkeyPrefix then
      if SysLocale.FarEast
      and ((I > 1) and (Length(Result) - I >= 2)
      and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin
        Delete(Result, I - 1, 4);
        Dec(I, 2);
      end else
        Delete(Result, I, 1);
    Inc(I);
  end;
end;

function WideSameCaption(const Text1, Text2: WideString): Boolean;
begin
  Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2));
end;

function WideSameCaptionStr(const Text1, Text2: WideString): Boolean;
begin
  Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2));
end;

function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
begin
  if MenuItem is TTntMenuItem then
    Result := TTntMenuItem(MenuItem).Caption
  else
    Result := MenuItem.Caption;
end;

function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
begin
  if MenuItem is TTntMenuItem then
    Result := TTntMenuItem(MenuItem).Hint
  else
    Result := MenuItem.Hint;
end;

procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
{If top-level items are created as owner-drawn, they will not appear as raised
buttons when the mouse hovers over them. The VCL will often create top-level
items as owner-drawn even when they don't need to be (owner-drawn state can be
set on an item-by-item basis). This routine turns off the owner-drawn flag for
top-level items if it appears unnecessary}

  function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean;
  var
    Images: TCustomImageList;
  begin
    Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil');
    Images := Item.GetImageList;
    Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count))
           or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty))
  end;

var
  HM: HMenu;
  i: integer;
  Info: TMenuItemInfoA;
  Item: TMenuItem{TNT-ALLOW TMenuItem};
  Win98Plus: boolean;
begin
  if Assigned(Menu) then begin
    Win98Plus:= (Win32MajorVersion > 4)
      or((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
    if not Win98Plus then
      Exit; {exit if Windows 95 or NT 4.0}
    HM:= Menu.Handle;
    Info.cbSize:= sizeof(Info);
    for i := 0 to GetMenuItemCount(HM) - 1 do begin
      Info.fMask:= MIIM_FTYPE or MIIM_ID;
      if not GetMenuItemInfo(HM, i, true, Info) then
        Break;
      if Info.fType and MFT_OWNERDRAW <> 0 then begin
        Item:= Menu.FindItem(Info.wID, fkCommand);
        if not Assigned(Item) then
          continue;
        if Assigned(Item.OnDrawItem)