rxmenus.pas

rxlib2.75控件包

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}

unit RxMenus;

{$I RX.INC}
{$S-,W-,R-}

interface

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} SysUtils,
  Classes, Controls, Messages, Graphics, {$IFDEF RX_D4} ImgList, {$ENDIF}
  Menus, RxHook;

type
  TRxMenuStyle = (msStandard, msOwnerDraw {$IFDEF WIN32}, msBtnLowered,
    msBtnRaised {$ENDIF});
  TMenuOwnerDrawState = set of (mdSelected, mdGrayed, mdDisabled, mdChecked,
    mdFocused {$IFDEF WIN32}, mdDefault {$ENDIF});

  TDrawMenuItemEvent = procedure(Sender: TMenu; Item: TMenuItem; Rect: TRect;
    State: TMenuOwnerDrawState) of object;
  TMeasureMenuItemEvent = procedure(Sender: TMenu; Item: TMenuItem; var Width,
    Height: Integer) of object;
  TDrawMarginEvent = procedure(Sender: TMenu; Rect: TRect) of object;
  TItemParamsEvent = procedure(Sender: TMenu; Item: TMenuItem;
    State: TMenuOwnerDrawState; AFont: TFont; var Color: TColor;
    var Graphic: TGraphic; var NumGlyphs: Integer) of object;
{$IFDEF WIN32}
  TItemImageEvent = procedure(Sender: TMenu; Item: TMenuItem;
    State: TMenuOwnerDrawState; var ImageIndex: Integer) of object;
{$ENDIF}

{ TRxMainMenu }

  TRxMainMenu = class(TMainMenu)
  private
    FStyle: TRxMenuStyle;
    FCanvas: TCanvas;
    FHook: TRxWindowHook;
    FShowCheckMarks: Boolean;
    FMinTextOffset: Cardinal;
    FCursor: TCursor;
    FOnDrawItem: TDrawMenuItemEvent;
    FOnMeasureItem: TMeasureMenuItemEvent;
    FOnGetItemParams: TItemParamsEvent;
{$IFDEF WIN32}
    FImages: TImageList;
    FImageChangeLink: TChangeLink;
    FOnGetImageIndex: TItemImageEvent;
    procedure SetImages(Value: TImageList);
    procedure ImageListChange(Sender: TObject);
{$ENDIF}
    procedure SetStyle(Value: TRxMenuStyle);
    function FindForm: TWinControl;
    procedure WndMessage(Sender: TObject; var AMsg: TMessage;
      var Handled: Boolean);
    procedure CMMenuChanged(var Message: TMessage); message CM_MENUCHANGED;
    procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
    procedure WMMeasureItem(var Message: TWMMeasureItem); message WM_MEASUREITEM;
    procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
  protected
    procedure Loaded; override;
{$IFDEF WIN32}
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;
      var ImageIndex: Integer); dynamic;
{$ENDIF}
    procedure DrawItem(Item: TMenuItem; Rect: TRect;
      State: TMenuOwnerDrawState); virtual;
    procedure GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;
      AFont: TFont; var Color: TColor; var Graphic: TGraphic;
      var NumGlyphs: Integer); dynamic;
    procedure MeasureItem(Item: TMenuItem; var Width, Height: Integer); dynamic;
    procedure RefreshMenu(AOwnerDraw: Boolean); virtual;
    function IsOwnerDrawMenu: Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Refresh;
    procedure DefaultDrawItem(Item: TMenuItem; Rect: TRect;
      State: TMenuOwnerDrawState);
    property Canvas: TCanvas read FCanvas;
  published
    property Cursor: TCursor read FCursor write FCursor default crDefault;
    property MinTextOffset: Cardinal read FMinTextOffset write FMinTextOffset default 0;
    property Style: TRxMenuStyle read FStyle write SetStyle default msStandard;
    property ShowCheckMarks: Boolean read FShowCheckMarks write FShowCheckMarks default True;
{$IFDEF RX_D4}
    property OwnerDraw stored False;
{$ENDIF}
{$IFDEF WIN32}
    property Images: TImageList read FImages write SetImages;
    property OnGetImageIndex: TItemImageEvent read FOnGetImageIndex write FOnGetImageIndex;
{$ENDIF}
    property OnDrawItem: TDrawMenuItemEvent read FOnDrawItem write FOnDrawItem;
    property OnGetItemParams: TItemParamsEvent read FOnGetItemParams write FOnGetItemParams;
    property OnMeasureItem: TMeasureMenuItemEvent read FOnMeasureItem write FOnMeasureItem;
  end;

{ TRxPopupMenu }

  TRxPopupMenu = class(TPopupMenu)
  private
    FStyle: TRxMenuStyle;
    FCanvas: TCanvas;
    FShowCheckMarks: Boolean;
    FMinTextOffset: Cardinal;
    FLeftMargin: Cardinal;
    FCursor: TCursor;
    FOnDrawItem: TDrawMenuItemEvent;
    FOnMeasureItem: TMeasureMenuItemEvent;
    FOnDrawMargin: TDrawMarginEvent;
    FOnGetItemParams: TItemParamsEvent;
{$IFDEF RX_D4}
    FPopupPoint: TPoint;
    FParentBiDiMode: Boolean;
{$ENDIF}
{$IFDEF WIN32}
    FImages: TImageList;
    FImageChangeLink: TChangeLink;
    FOnGetImageIndex: TItemImageEvent;
    procedure SetImages(Value: TImageList);
    procedure ImageListChange(Sender: TObject);
{$ENDIF}
    procedure SetStyle(Value: TRxMenuStyle);
    procedure WndMessage(Sender: TObject; var AMsg: TMessage;
      var Handled: Boolean);
    procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
    procedure WMMeasureItem(var Message: TWMMeasureItem); message WM_MEASUREITEM;
{$IFDEF RX_D4}
    procedure SetBiDiModeFromPopupControl;
{$ENDIF}
  protected
    procedure Loaded; override;
{$IFDEF RX_D4}
    function UseRightToLeftAlignment: Boolean;
{$ENDIF}
{$IFDEF WIN32}
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;
      var ImageIndex: Integer); dynamic;
{$ENDIF}
    procedure DrawItem(Item: TMenuItem; Rect: TRect;
      State: TMenuOwnerDrawState); virtual;
    procedure DrawMargin(ARect: TRect); virtual;
    procedure GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;
      AFont: TFont; var Color: TColor; var Graphic: TGraphic;
      var NumGlyphs: Integer); dynamic;
    procedure MeasureItem(Item: TMenuItem; var Width, Height: Integer); dynamic;
    procedure RefreshMenu(AOwnerDraw: Boolean); virtual;
    function IsOwnerDrawMenu: Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Refresh;
    procedure Popup(X, Y: Integer); override;
    procedure DefaultDrawItem(Item: TMenuItem; Rect: TRect;
      State: TMenuOwnerDrawState);
    procedure DefaultDrawMargin(ARect: TRect; StartColor, EndColor: TColor);
    property Canvas: TCanvas read FCanvas;
  published
    property Cursor: TCursor read FCursor write FCursor default crDefault;
    property LeftMargin: Cardinal read FLeftMargin write FLeftMargin default 0;
    property MinTextOffset: Cardinal read FMinTextOffset write FMinTextOffset default 0;
    property Style: TRxMenuStyle read FStyle write SetStyle default msStandard;
    property ShowCheckMarks: Boolean read FShowCheckMarks write FShowCheckMarks default True;
{$IFDEF RX_D4}
    property OwnerDraw stored False;
{$ENDIF}
{$IFDEF WIN32}
    property Images: TImageList read FImages write SetImages;
    property OnGetImageIndex: TItemImageEvent read FOnGetImageIndex write FOnGetImageIndex;
{$ENDIF}
    property OnDrawItem: TDrawMenuItemEvent read FOnDrawItem write FOnDrawItem;
    property OnDrawMargin: TDrawMarginEvent read FOnDrawMargin write FOnDrawMargin;
    property OnGetItemParams: TItemParamsEvent read FOnGetItemParams write FOnGetItemParams;
    property OnMeasureItem: TMeasureMenuItemEvent read FOnMeasureItem write FOnMeasureItem;
  end;

{ Utility routines }

procedure SetDefaultMenuFont(AFont: TFont);
function IsItemPopup(Item: TMenuItem): Boolean;

implementation

uses {$IFDEF WIN32} CommCtrl, {$ENDIF} Forms, ExtCtrls, Consts, RxConst,
  MaxMin, VclUtils, ClipIcon, rxStrUtils;

const
  DefMarginColor: TColor = clBlue;
  AddWidth = 2;
  AddHeight = 4;
  Tab = #9#9;
  Separator = '-';

type
  TBtnStyle = (bsNone, bsLowered, bsRaised, bsOffice);

function BtnStyle(MenuStyle: TRxMenuStyle): TBtnStyle;
begin
{$IFDEF WIN32}
  case MenuStyle of
    msBtnLowered: Result := bsLowered;
    msBtnRaised: Result := bsRaised;
    else Result := bsNone;
  end;
{$ELSE}
  Result := bsNone;
{$ENDIF}
end;

function IsItemPopup(Item: TMenuItem): Boolean;
begin
  Result := (Item.Parent = nil) or (Item.Parent.Parent <> nil) or
    not (Item.Parent.Owner is TMainMenu);
end;

{$IFNDEF WIN32}
const
  { return codes for WM_MENUCHAR (not defined in Delphi 1.0) }
  MNC_IGNORE = 0;
  MNC_CLOSE = 1;
  MNC_EXECUTE = 2;
  MNC_SELECT = 3;
{$ENDIF}

{$IFNDEF RX_D4}
procedure ProcessMenuChar(AMenu: TMenu; var Message: TWMMenuChar);
var
  C, I, First, Hilite, Next: Integer;
  State: Word;

  function IsAccelChar(Menu: HMENU; State: Word; I: Integer; C: Char): Boolean;
  var
    Item: TMenuItem;
    Id: Cardinal;
  begin
    Item := nil;
    if State and MF_POPUP <> 0 then begin
      Menu := GetSubMenu(Menu, I);
      Item := AMenu.FindItem(Menu, fkHandle);
    end
    else begin
      Id := GetMenuItemID(Menu, I);
      if Id <> {$IFDEF WIN32} $FFFFFFFF {$ELSE} $FFFF {$ENDIF} then
        Item := AMenu.FindItem(Id, fkCommand);
    end;
    if Item <> nil then Result := IsAccel(Ord(C), Item.Caption)
    else Result := False;
  end;

  function IsInitialChar(Menu: HMENU; State: Word; I: Integer; C: Char): Boolean;
  var
    Item: TMenuItem;
  begin
    if State and MF_POPUP <> 0 then begin
      Menu := GetSubMenu(Menu, I);
      Item := AMenu.FindItem(Menu, fkHandle);
    end
    else begin
      Item := AMenu.FindItem(Menu, fkHandle);
      if Item <> nil then Item := Item.Items[I];
    end;
    if (Item <> nil) and (Item.Caption <> '') then
      Result := AnsiCompareText(Item.Caption[1], C) = 0
    else Result := False;
  end;

begin
  with Message do begin
    Result := MNC_IGNORE; { No item found: beep }
    First := -1;
    Hilite := -1;
    Next := -1;
    C := GetMenuItemCount(Menu);
    for I := 0 to C - 1 do begin
      State := GetMenuState(Menu, I, MF_BYPOSITION);
      if IsAccelChar(Menu, State, I, User) then begin
        if State and MF_DISABLED <> 0 then begin
          { Close the menu if this is the only disabled item to choose from.
            Otherwise, ignore the item. }
          if First < 0 then First := -2;
          Continue;
        end;
        if First < 0 then begin
          First := I;
          Result := MNC_EXECUTE;
        end
        else Result := MNC_SELECT;
        if State and MF_HILITE <> 0 then Hilite := I
        else if Hilite >= 0 then Next := I;
      end;
    end;
    { We found a single disabled item. End the selection. }
    if First < -1 then begin
      Result := MNC_CLOSE shl 16;
      Exit;
    end;

    { If we can't find accelerators, then look for initial letters }
    if First < 0 then
      for I := 0 to C - 1 do begin
        State := GetMenuState(Menu, I, MF_BYPOSITION);
        if IsInitialChar(Menu, State, I, User) then begin
          if State and MF_DISABLED <> 0 then begin
            Result := MNC_CLOSE shl 16;
            Exit;
          end;
          if First < 0 then begin
            First := I;
            Result := MNC_EXECUTE;
          end
          else Result := MNC_SELECT;
          if State and MF_HILITE <> 0 then Hilite := I
          else if Hilite >= 0 then Next := I;
        end;
      end;

    if (Result = MNC_EXECUTE) then Result := Result shl 16 or First
    else if Result = MNC_SELECT then begin
      if Next < 0 then Next := First;
      Result := Result shl 16 or Next;
    end;
  end;
end;
{$ENDIF RX_D4}

procedure MenuWndMessage(Menu: TMenu; var AMsg: TMessage; var Handled: Boolean);
var
  Message: TMessage;
  Item: Pointer;
begin
  with AMsg do
    case Msg of
      WM_MEASUREITEM:
        if (TWMMeasureItem(AMsg).MeasureItemStruct^.CtlType = ODT_MENU) then
        begin
          Item := Menu.FindItem(TWMMeasureItem(AMsg).MeasureItemStruct^.itemID, fkCommand);
          if Item <> nil then begin
            Message := AMsg;
            TWMMeasureItem(Message).MeasureItemStruct^.ItemData := Longint(Item);
            Menu.Dispatch(Message);
            Result := 1;
            Handled := True;
          end;
        end;
      WM_DRAWITEM:
        if (TWMDrawItem(AMsg).DrawItemStruct^.CtlType = ODT_MENU) then
        begin
          Item := Menu.FindItem(TWMDrawItem(AMsg).DrawItemStruct^.itemID, fkCommand);
          if Item <> nil then begin
            Message := AMsg;
            TWMDrawItem(Message).DrawItemStruct^.ItemData := Longint(Item);
            Menu.Dispatch(Message);
            Result := 1;
            Handled := True;
          end;
        end;
      WM_MENUSELECT: Menu.Dispatch(AMsg);
      CM_MENUCHANGED: Menu.Dispatch(AMsg);
      WM_MENUCHAR:
        begin
{$IFDEF RX_D4}
          Menu.ProcessMenuChar(TWMMenuChar(AMsg));
{$ELSE}
          ProcessMenuChar(Menu, TWMMenuChar(AMsg));
{$ENDIF}
        end;
    end;
end;

{$IFNDEF RX_D4}
procedure RefreshMenuItem(MenuItem: TMenuItem; OwnerDraw: Boolean);
const
  Breaks: array[TMenuBreak] of Longint = (0, MF_MENUBREAK, MF_MENUBARBREAK);
  Checks: array[Boolean] of LongInt = (MF_UNCHECKED, MF_CHECKED);
  Enables: array[Boolean] of LongInt = (MF_DISABLED or MF_GRAYED, MF_ENABLED);
  Separators: array[Boolean] of LongInt = (MF_STRING, MF_SEPARATOR);
{$IFDEF WIN32}
  IBreaks: array[TMenuBreak] of DWORD = (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);
  IRadios: array[Boolean] of DWORD = (MFT_STRING, MFT_RADIOCHECK);
  ISeparators: array[Boolean] of DWORD = (MFT_STRING, MFT_SEPARATOR);
  IOwnerDraw: array[Boolean] of DWORD = (MFT_STRING, MFT_OWNERDRAW);
{$ENDIF}
var
{$IFDEF WIN32}
  MenuItemInfo: TMenuItemInfo;
{$ENDIF}
  CCaption: array[0..255] of Char;
  NewFlags: Integer;
  ItemID, I, C: Integer;
  MenuHandle: THandle;
  Item: TMenuItem;

{$IFDEF WIN32}
  procedure PrepareItemInfo;
  begin
    FillChar(MenuItemInfo, SizeOf(TMenuItemInfo), 0);
    with MenuItemInfo do begin
      cbSize := SizeOf(TMenuItemInfo);
      fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or MIIM_STATE or
        MIIM_SUBMENU or MIIM_TYPE;
      cch := SizeOf(CCaption) - 1;
    end;
  end;
{$ENDIF}

begin
  if (MenuItem <> nil) then begin
    StrPCopy(CCaption, MenuItem.Caption);
    NewFlags := Breaks[MenuItem.Break] or Checks[MenuItem.Checked] or
      Enables[MenuItem.Enabled] or Separators[MenuItem.Caption = Separator] or
      MF_BYCOMMAND;
    ItemID := MenuItem.Command;
    if MenuItem.Count > 0 then begin
      NewFlags := NewFlags or MF_POPUP;
      ItemID := MenuItem.Handle;
    end
    else begin
      if (MenuItem.ShortCut <> scNone) and ((MenuItem.Parent = nil) or
        (MenuItem.Parent.Parent <> nil) or
        not (MenuItem.Parent.Owner is TMainMenu)) then
          StrPCopy(StrECopy(StrEnd(CCaption), Tab),
            ShortCutToText(MenuItem.ShortCut));
    end;
    Item := MenuItem;
    while Item.Parent <> nil do Item := Item.Parent;
    if (Item.Owner <> nil) and (Item.Owner is TMenu) then
      MenuHandle := TMenu(Item.Owner).Handle
    else
      MenuHandle := Item.Handle;
{$IFDEF WIN32}
    if Lo(GetVersion) >= 4 then begin
      FillChar(MenuItemInfo, SizeOf(TMenuItemInfo), 0);
      MenuItemInfo.cbSize := SizeOf(TMenuItemInfo);
      if MenuItem.Count > 0 then begin
        MenuItemInfo.fMask := MIIM_DATA or MIIM_TYPE;
        with MenuItem do
          MenuItemInfo.fType := IRadios[RadioItem] or IBreaks[Break] or
            ISeparators[Caption = Separator] or IOwnerDraw[OwnerDraw];
        MenuItemInfo.dwTypeData := CCaption;
        SetMenuItemInfo(MenuHandle, MenuItem.Command, False, MenuItemInfo);
      end
      else begin
        C := GetMenuItemCount(MenuHandle);
        ItemID := -1;
        for I := 0 to C - 1 do begin
          PrepareItemInfo;
          MenuItemInfo.dwTypeData := CCaption;
          GetMenuItemInfo(MenuHandle, I, True, MenuItemInfo);
          if MenuItemInfo.wID = MenuItem.Command then begin
            ItemID := I;
            Break;
          end;
        end;
        if (ItemID < 0) and (MenuItem.Parent <> nil) then begin
          MenuHandle := MenuItem.Parent.Handle;
          C := GetMenuItemCount(MenuHandle);