unit SysMenu;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Menus;

type
  TSystemMenu = class(TComponent)
  private
    FSystemMenu: TPopupMenu;
    FForm: TCustomForm;

    FNewFormWndProcInstance: Pointer;
    FOldFormWndProc: Pointer;
    procedure AddMenu(Menu: TMenuitem; handle: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NewFormWndProc(var Message: TMessage);
  published
    property SystemMenu: TPopupMenu read FSystemMenu write FSystemMenu;
  end;

procedure Register;

implementation

const
  FTPUCount: Integer = 0;

procedure Register;
begin
  RegisterComponents('Samples', [TSystemMenu]);
end;

constructor TSystemMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (AOwner is TCustomForm) then
  begin
    FForm := AOwner as TCustomForm;
    FSystemMenu := nil;
    if not (csDesigning in ComponentState) then
    begin
      FNewFormWndProcInstance := MakeObjectInstance(NewFormWndProc);
      FOldFormWndProc := Pointer(GetWindowLong(FForm.Handle, GWL_WNDPROC));
      SetWindowLong(FForm.Handle, GWL_WNDPROC,
        Longint(FNewFormWndProcInstance));
    end;
  end;
end;

destructor TSystemMenu.Destroy;
begin
  if not (csDesigning in ComponentState) then
    FreeObjectInstance(FNewFormWndProcInstance);

  inherited Destroy;
end;

procedure TSystemMenu.NewFormWndProc(var Message: TMessage);
var
  Menu: TMenuItem;
  c, handle: Integer;
begin
  case Message.Msg of
    WM_SYSCOMMAND:
      begin
        Menu := FSystemMenu.FindItem(Message.wparam, fkCommand);
        if Menu <> nil then
          Menu.Click;
      end;
    WM_INITMENU:
      begin
        handle := GetSystemMenu(FForm.Handle, False);
        for c := 0 to FSystemMenu.Items.Count - 1 do
          DeleteMenu(handle, FSystemMenu.Items[c].Command, MF_BYCOMMAND);
        AddMenu(FSystemMenu.items, handle);
      end;
  end;
  Message.Result := CallWindowProc(FOldFormWndProc, (Owner as TForm).Handle,
    Message.Msg, Message.WParam, Message.LParam);
end;

procedure TSystemMenu.AddMenu(Menu: TMenuItem; handle: Integer);
var
  c: integer;
  flags: integer;
begin
  if (Menu <> nil) and (Menu.count > 0) then
    for c := 0 to Menu.count - 1 do
    begin
      if Menu.items[c].caption <> '-' then
      begin
        if Menu.items[c].Visible then
        begin
          flags := MF_STRING;
          if Menu.Items[c].Checked then
            flags := flags + MF_CHECKED;
          if not Menu.Items[c].Enabled then
            flags := flags + MF_GRAYED;
          if Menu.Items[c].Break = mbBreak then
            flags := flags + MF_MENUBREAK;
          if Menu.Items[c].Break = mbBarBreak then
            flags := flags + MF_MENUBARBREAK;

          AppendMenu(handle, flags, Menu.items[c].command,
            PChar(Menu.Items[c].Caption + #9 +
            ShortCutToText(Menu.Items[c].ShortCut)));
        end;
      end
      else
        AppendMenu(handle, MF_SEPARATOR, Menu.items[c].command, nil);
    end;
end;

end.