unit moremenu;

{ ************************************************************ }
{ A simple TMenuBar extension to implement boolean checkmarked }
{ menu items.                                                  }
{                                                              }
{ Copyright (c) 1990 by Danny Thorpe                           }
{**************************************************************}

interface
uses Drivers, Menus;

type
  PCheckMarkMenuBar = ^TCheckMarkMenuBar;
  TCheckMarkMenuBar = object(TMenuBar)
    procedure HandleEvent(var E: TEvent); virtual;
    procedure MarkToggle(Cmd: word);
    procedure MarkSet(Cmd : word);
    procedure MarkClear(Cmd: word);
    function  MarkIsSet(Cmd: word): boolean;
    end;


function FindCmd(AMenu: PMenu; Cmd: word): PMenuItem;


const MarkChar: char = #251;  { square root symbol }
      MarkStart = 1000; { start of the checkmark command range }
      MarkEnd: word = 1600; { that's 200 checkmark command sets }

{ checkmark command sets are groups of 3 command constants in
  sequential order.  The first is cmToggle[name], the
  second is cmSet[name], and the third is cmClear[name].  For example:

const cmToggleWidget = 1000;  (* the start of the checkmark command range *)
      cmSetWidget = 1001;
      cmClearWidget = 1002;

Use cmToggle[name] for the command constant when you init the menu item.
The other commands and methods are for your program to query or explicity
clear or set the checkmark.
}

implementation

procedure TCheckMarkMenuBar.HandleEvent(var E: TEvent);
  begin
  if E.What = evCommand then
    if (E.Command >= MarkStart) and
       (E.Command <= MarkEnd) then
      begin
      case (E.Command mod 3) of
        (MarkStart mod 3) : MarkToggle(E.Command);
        (MarkStart+1 mod 3) : MarkSet(E.Command-1);
        (MarkStart+2 mod 3) : MarkClear(E.Command-2);
        end;
      ClearEvent(E);
      end;
  TMenuBar.HandleEvent(E);
  end;


procedure TCheckMarkMenuBar.MarkToggle(Cmd: word);
  begin
  if MarkIsSet(Cmd) then
    MarkClear(Cmd)
  else
    MarkSet(Cmd);
  end;


procedure TCheckMarkMenuBar.MarkSet(Cmd: word);
  var P: PMenuItem;
  begin
  P := FindCmd(Menu, Cmd);
  if P <> nil then
    P^.Name^[1] := MarkChar;
  end;


procedure TCheckMarkMenuBar.MarkClear(Cmd: word);
  var P: PMenuItem;
  begin
  P := FindCmd(Menu, Cmd);
  if P <> nil then
    P^.Name^[1] := ' ';
  end;


function TCheckMarkMenuBar.MarkIsSet(Cmd: word): boolean;
  var P: PMenuItem;
  begin
  MarkIsSet := false;
  P := FindCmd(Menu, Cmd);
  if P <> nil then
    MarkIsSet := (P^.Name^[1] = MarkChar);
  end;


function FindCmd(AMenu: PMenu; Cmd: word): PMenuItem;
  var P,Q: PMenuItem;
  begin
  P := AMenu^.Items;
  while P <> nil do
    begin
    if (P^.Command = 0) and (P^.Name <> nil) then
      begin
      Q := FindCmd(P^.SubMenu, Cmd);
      if Q <> nil then
        begin
        FindCmd := Q;
        Exit;
        end;
      end
    else
      if (P^.Command = Cmd) and not P^.Disabled then
        begin
        FindCmd := P;
        Exit;
        end;
    P := P^.Next;
    end;
  FindCmd := nil;
  end;



begin
end.