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

unit Dpi.Menus;

interface

uses
  Classes, SysUtils, LCLType, Menus;

type
  { TMenuItem }

   TMenuItem = class(TComponent)
   private
     FItems: TList;
     FParent: TMenuItem;
     FOnClick: TNotifyEvent;
     function GetCaption: TTranslateString;
     function GetChecked: Boolean;
     function GetCount: Integer;
     function GetEnabled: Boolean;
     function GetGroupIndex: Byte;
     function GetItem(Index: Integer): TMenuItem;
     function GetOnClick: TNotifyEvent;
     function GetRadioItem: Boolean;
     function GetShortCut: TShortCut;
     function GetVisible: Boolean;
     function IsCaptionStored: Boolean;
     function IsCheckedStored: Boolean;
     function IsEnabledStored: Boolean;
     function IsShortCutStored: Boolean;
     function IsVisibleStored: Boolean;
     procedure SetCaption(AValue: TTranslateString);
     procedure SetChecked(AValue: Boolean);
     procedure SetEnabled(AValue: Boolean);
     procedure SetGroupIndex(AValue: Byte);
     procedure SetOnClick(AValue: TNotifyEvent);
     procedure SetRadioItem(AValue: Boolean);
     procedure SetShortCut(AValue: TShortCut);
     procedure SetVisible(AValue: Boolean);
     procedure OnClickHandler(Sender: TObject);
   protected
     function GetNativeMenuItem: Menus.TMenuItem; virtual;
     procedure SetParentComponent(AValue: TComponent); override;
   public
     NativeMenuItem: Menus.TMenuItem;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure Delete(Index: Integer);
     procedure Add(Item: TMenuItem);
     procedure Insert(Index: Integer; Item: TMenuItem);
     function IndexOf(Item: TMenuItem): Integer;
     procedure Remove(Item: TMenuItem);
     property Items[Index: Integer]: TMenuItem read GetItem; default;
     property Count: Integer read GetCount;
     procedure Clear;
     procedure Click; virtual;
   published
     property RadioItem: Boolean read GetRadioItem write SetRadioItem default False;
     property ShortCut: TShortCut read GetShortCut write SetShortCut
       stored IsShortCutStored default 0;
     property Enabled: Boolean read GetEnabled write SetEnabled
       stored IsEnabledStored default True;
     property Visible: Boolean read GetVisible write SetVisible
       stored IsVisibleStored default True;
     property Checked: Boolean read GetChecked write SetChecked
       stored IsCheckedStored default False;
     property Caption: TTranslateString read GetCaption write SetCaption
       stored IsCaptionStored;
     property OnClick: TNotifyEvent read GetOnClick write SetOnClick;
     property GroupIndex: Byte read GetGroupIndex write SetGroupIndex default 0;
   end;

   TMenu = class(TComponent)
   private
     FItems: TMenuItem;
   protected
     function GetNativeMenu: Menus.TMenu; virtual;
   public
     property Items: TMenuItem read FItems;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   end;

   { TPopupMenu }

   TPopupMenu = class(TMenu)
   private
     function GetAutoPopup: Boolean;
     procedure SetAutoPopup(AValue: Boolean);
   protected
     function GetNativeMenu: Menus.TMenu; override;
     function GetNativePopupMenu: Menus.TPopupMenu; virtual;
   public
     NativePopupMenu: Menus.TPopupMenu;
     procedure PopUp;  overload;
     procedure PopUp(X, Y: Integer); virtual; overload;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property AutoPopup: Boolean read GetAutoPopup write SetAutoPopup default True;
   end;

function ShortCut(const Key: Word; const Shift: TShiftState): TShortCut;
procedure Register;


implementation

uses
  Dpi.Common, Dpi.Controls, LCLStrConsts;

function ShortCut(const Key: Word; const Shift: TShiftState): TShortCut;
begin
  Result := Menus.ShortCut(Key, Shift);
end;

procedure Register;
begin
  RegisterComponents(DpiControlsComponentPaletteName, [TPopupMenu]);
end;

{ TMenu }

function TMenu.GetNativeMenu: Menus.TMenu;
begin
  Result := nil;
end;

constructor TMenu.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TMenuItem.Create(Self);
end;

destructor TMenu.Destroy;
begin
  FreeAndNil(FItems);
  inherited;
end;

{ TMenuItem }

function TMenuItem.GetCaption: TTranslateString;
begin
  Result := GetNativeMenuItem.Caption;
end;

function TMenuItem.GetChecked: Boolean;
begin
  Result := GetNativeMenuItem.Checked;
end;

function TMenuItem.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TMenuItem.GetEnabled: Boolean;
begin
  Result := GetNativeMenuItem.Enabled;
end;

function TMenuItem.GetGroupIndex: Byte;
begin
  Result := GetNativeMenuItem.GroupIndex;
end;

function TMenuItem.GetItem(Index: Integer): TMenuItem;
begin
  Result := TMenuItem(FItems[Index]);
end;

function TMenuItem.GetOnClick: TNotifyEvent;
begin
  Result := FOnClick;
end;

function TMenuItem.GetRadioItem: Boolean;
begin
  Result := GetNativeMenuItem.RadioItem;
end;

function TMenuItem.GetShortCut: TShortCut;
begin
  Result := GetNativeMenuItem.ShortCut;
end;

function TMenuItem.GetVisible: Boolean;
begin
  Result := GetNativeMenuItem.Visible;
end;

function TMenuItem.IsCaptionStored: Boolean;
begin
  Result := False;
end;

function TMenuItem.IsCheckedStored: Boolean;
begin
  Result := False;
end;

function TMenuItem.IsEnabledStored: Boolean;
begin
  Result := False;
end;

function TMenuItem.IsShortCutStored: Boolean;
begin
  Result := False;
end;

function TMenuItem.IsVisibleStored: Boolean;
begin
  Result := False;
end;

procedure TMenuItem.SetCaption(AValue: TTranslateString);
begin
  GetNativeMenuItem.Caption := AValue;
end;

procedure TMenuItem.SetChecked(AValue: Boolean);
begin
  GetNativeMenuItem.Checked := AValue;
end;

procedure TMenuItem.SetEnabled(AValue: Boolean);
begin
  GetNativeMenuItem.Enabled := AValue;
end;

procedure TMenuItem.SetGroupIndex(AValue: Byte);
begin
  GetNativeMenuItem.GroupIndex := AValue;
end;

procedure TMenuItem.SetOnClick(AValue: TNotifyEvent);
begin
  FOnClick := AValue;
end;

procedure TMenuItem.SetRadioItem(AValue: Boolean);
begin
  GetNativeMenuItem.RadioItem := AValue;
end;

procedure TMenuItem.SetShortCut(AValue: TShortCut);
begin
  GetNativeMenuItem.ShortCut := AValue;
end;

procedure TMenuItem.SetVisible(AValue: Boolean);
begin
  GetNativeMenuItem.Visible := AValue;
end;

procedure TMenuItem.OnClickHandler(Sender: TObject);
begin
  if Assigned(FOnClick) then
    FOnClick(Self);
end;

procedure TMenuItem.Delete(Index: Integer);
begin
  FItems.Delete(Index);
  GetNativeMenuItem.Delete(Index);
end;

procedure TMenuItem.Add(Item: TMenuItem);
begin
  Insert(GetCount, Item);
end;

procedure TMenuItem.Insert(Index: Integer; Item: TMenuItem);
begin
  FItems.Insert(Index, Item);
  GetNativeMenuItem.Insert(Index, Item.GetNativeMenuItem);
end;

function TMenuItem.IndexOf(Item: TMenuItem): Integer;
begin
  if FItems = nil then
    Result := -1
  else
    Result := FItems.IndexOf(Item);
end;

procedure TMenuItem.Remove(Item: TMenuItem);
var
  I: Integer;
begin
  I := IndexOf(Item);
  if I < 0 then
    raise EMenuError.Create(SMenuNotFound);
  Delete(I);
end;

procedure TMenuItem.Clear;
begin
  GetNativeMenuItem.Clear;
  FItems.Clear;
end;

procedure TMenuItem.Click;
begin
  GetNativeMenuItem.Click;
end;

function TMenuItem.GetNativeMenuItem: Menus.TMenuItem;
begin
  if not Assigned(NativeMenuItem) then begin
    NativeMenuItem := Menus.TMenuItem.Create(nil);
    NativeMenuItem.Name := 'Native' + Name;
    NativeMenuItem.OnClick := OnClickHandler;
  end;
  Result := NativeMenuItem;
end;

procedure TMenuItem.SetParentComponent(AValue: TComponent);
begin
  if (FParent = AValue) then Exit;
  if Assigned(FParent) then FParent.Remove(Self);
  if Assigned(AValue) then
  begin
    if (AValue is TMenu)
      then TMenu(AValue).Items.Add(Self)
    else if (AValue is TMenuItem)
      then TMenuItem(AValue).Add(Self)
    else
      raise Exception.Create('TDpiMenuItem.SetParentComponent: suggested parent not of type TDpiMenu or TDpiMenuItem');
   end;
end;

constructor TMenuItem.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TList.Create;
end;

destructor TMenuItem.Destroy;
begin
  FreeAndNil(FItems);
  // TODO: Release menu items
  //FreeAndNil(NativeMenuItem);
  inherited;
end;

{ TPopupMenu }

procedure TPopupMenu.PopUp;
var
  Pos: TPoint;
begin
  Pos := Mouse.CursorPos;
  Popup(Pos.X, Pos.Y);
end;

procedure TPopupMenu.PopUp(X, Y: Integer);
begin
  GetNativePopupMenu.PopUp(ScaleToNative(X), ScaleToNative(Y));
end;

constructor TPopupMenu.Create(AOwner: TComponent);
begin
  inherited;
  GetNativePopupMenu;
end;

function TPopupMenu.GetAutoPopup: Boolean;
begin
  Result := GetNativePopupMenu.AutoPopup;
end;

procedure TPopupMenu.SetAutoPopup(AValue: Boolean);
begin
  GetNativePopupMenu.AutoPopup := AValue;
end;

function TPopupMenu.GetNativeMenu: Menus.TMenu;
begin
  Result := GetNativePopupMenu;
end;

function TPopupMenu.GetNativePopupMenu: Menus.TPopupMenu;
begin
  if not Assigned(NativePopupMenu) then begin
    NativePopupMenu := Menus.TPopupMenu.Create(nil);
    if Assigned(Items.NativeMenuItem) then Items.NativeMenuItem.Free;
    Items.NativeMenuItem := NativePopupMenu.Items;
  end;
  Result := NativePopupMenu;
end;

destructor TPopupMenu.Destroy;
begin
  if Assigned(NativePopupMenu) then FreeAndNil(NativePopupMenu);
  inherited;
end;


end.