Home: Code Repository: Mastering Delphi 5

Project DYNAMENU

Project Structure

DYNAMENU.DPR
MENUF.PAS
MENUF.DFM

program DynaMenu;

uses
  Forms,
  MenuF in 'MenuF.pas' {FormColorText}; {FormColorText}

{$R *.RES}

begin
  Application.CreateForm(TFormColorText, FormColorText);
  Application.Run;
end.

unit MenuF;

interface

uses
  SysUtils, Windows, Classes, Graphics, Forms, Controls,
  StdCtrls, Menus, Dialogs, ExtCtrls;

type
  TFormColorText = class(TForm)
    Label1: TLabel;
    ColorDialog1: TColorDialog;
    MainMenu1: TMainMenu;
    FontDialog1: TFontDialog;
    Options1: TMenuItem;
    Font1: TMenuItem;
    BackColor1: TMenuItem;
    N1: TMenuItem;
    Left1: TMenuItem;
    Center1: TMenuItem;
    Right1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    File1: TMenuItem;
    Exit1: TMenuItem;
    N3: TMenuItem;
    DisableHelp1: TMenuItem;
    procedure About1Click(Sender: TObject);
    procedure Font1Click(Sender: TObject);
    procedure BackColor1Click(Sender: TObject);
    procedure Left1Click(Sender: TObject);
    procedure Center1Click(Sender: TObject);
    procedure Right1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure DisableHelp1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  public
    procedure SizeItemClick(Sender: TObject);
    procedure SizeClick(Sender: TObject);
  end;

var
  FormColorText: TFormColorText;

implementation

{$R *.DFM}

procedure TFormColorText.About1Click(Sender: TObject);
begin
  MessageDlg ('DynaMenu creates part of the menu at runtime'#13#13 +
    'from the book "Mastering Delphi 4" by Marco Cantù',
    mtInformation, [mbOk], 0);
end;

procedure TFormColorText.Font1Click(Sender: TObject);
begin
  with FontDialog1 do
  begin
    Font := Label1.Font;
    if Execute then
      Label1.Font := Font;
  end;
end;

procedure TFormColorText.BackColor1Click(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    Color := Label1.Color;
    if Execute then
      Label1.Color := Color;
  end;
end;

procedure TFormColorText.Left1Click(Sender: TObject);
begin
  Label1.Alignment := taLeftJustify;
  Left1.Checked := True;
end;

procedure TFormColorText.Center1Click(Sender: TObject);
begin
  Label1.Alignment := taCenter;
  Center1.Checked := True;
end;

procedure TFormColorText.Right1Click(Sender: TObject);
begin
  Label1.Alignment := taRightJustify;
  Right1.Checked := True;
end;

procedure TFormColorText.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TFormColorText.DisableHelp1Click(Sender: TObject);
begin
  DisableHelp1.Checked := not DisableHelp1.Checked;
  Help1.Enabled := not Help1.Enabled;
end;

procedure TFormColorText.FormCreate(Sender: TObject);
var
  PullDown, Item: TMenuItem;
  Position, I: Integer;
begin
  // create the new pulldown menu
  PullDown := TMenuItem.Create (Self);
  PullDown.AutoHotkeys := maManual;
  PullDown.Caption := 'Size';
  PullDown.OnClick := SizeClick;
  // compute the position and add it
  Position := MainMenu1.Items.IndexOf (Options1);
  MainMenu1.Items.Insert (Position + 1, PullDown);
  // create menu items for various sizes
  I := 8;
  while I <= 48 do
  begin
    // create the new item
    Item := TMenuItem.Create (Self);
    Item.Caption := IntToStr (I);
    // make it a radio item
    Item.GroupIndex := 1;
    Item.RadioItem := True;
    // handle click and insert
    Item.OnClick := SizeItemClick;
    PullDown.Insert (PullDown.Count, Item);
    I := I + 4;
  end;
  // add extra item at the end
  Item := TMenuItem.Create (Self);
  Item.Caption := '&More...';
  // make it a radio item
  Item.GroupIndex := 1;
  Item.RadioItem := True;
  // handle it by showing the font selection dialog
  Item.OnClick := Font1Click;
  PullDown.Insert (PullDown.Count, Item);
end;

procedure TFormColorText.SizeItemClick(Sender: TObject);
begin
  with Sender as TMenuItem do
    Label1.Font.Size := StrToInt (Caption);
end;

procedure TFormColorText.SizeClick (Sender: TObject);
var
  I: Integer;
  Found: Boolean;
begin
  Found := False;
  with Sender as TMenuItem do
  begin
    // look for a match, skipping the last item
    for I := 0 to Count - 2 do
      if StrToInt (Items [I].Caption) =
        Label1.Font.Size then
      begin
        Items [I].Checked := True;
        Found := True;
        System.Break; // skip the rest of the loop
      end;
    if not Found then
      Items [Count - 1].Checked := True;
  end;
end;

end.

object FormColorText: TFormColorText
  Left = 270
  Top = 112
  Width = 455
  Height = 273
  Caption = 'Dynamic Menu'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 0
    Top = 0
    Width = 447
    Height = 227
    Align = alClient
    Alignment = taCenter
    AutoSize = False
    Caption =
       'Select the menu commands to change the font or the background co' +
      'lor of this label, and the alignment of its text'
    Color = clYellow
    Font.Charset = ANSI_CHARSET
    Font.Color = clNavy
    Font.Height = -37
    Font.Name = 'Arial'
    Font.Style = []
    ParentColor = False
    ParentFont = False
    WordWrap = True
  end
  object ColorDialog1: TColorDialog
    Ctl3D = True
    Left = 32
    Top = 72
  end
  object MainMenu1: TMainMenu
    Left = 32
    Top = 136
    object File1: TMenuItem
      Caption = '&File'
      object Exit1: TMenuItem
        Caption = 'E&xit'
        OnClick = Exit1Click
      end
    end
    object Options1: TMenuItem
      Caption = '&Options'
      object Font1: TMenuItem
        Caption = '&Font...'
        OnClick = Font1Click
      end
      object BackColor1: TMenuItem
        Caption = '&Back Color...'
        OnClick = BackColor1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object Left1: TMenuItem
        Caption = '&Left'
        GroupIndex = 1
        RadioItem = True
        ShortCut = 16460
        OnClick = Left1Click
      end
      object Center1: TMenuItem
        Caption = '&Center'
        Checked = True
        GroupIndex = 1
        RadioItem = True
        ShortCut = 16451
        OnClick = Center1Click
      end
      object Right1: TMenuItem
        Caption = '&Right'
        GroupIndex = 1
        RadioItem = True
        ShortCut = 16466
        OnClick = Right1Click
      end
      object N3: TMenuItem
        Caption = '-'
        GroupIndex = 1
      end
      object DisableHelp1: TMenuItem
        Caption = 'Disable &Help'
        GroupIndex = 1
        OnClick = DisableHelp1Click
      end
    end
    object Help1: TMenuItem
      Caption = '&Help'
      object About1: TMenuItem
        Caption = '&About...'
        OnClick = About1Click
      end
    end
  end
  object FontDialog1: TFontDialog
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    MinFontSize = 0
    MaxFontSize = 0
    Left = 32
    Top = 16
  end
end