home *** CD-ROM | disk | FTP | other *** search
- 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.
-