Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 06 - Project QDynaMenu

Project Structure

QDynaMenu.dpr
program QDynaMenu;

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

{$R *.res}

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

interface

uses
  SysUtils, Qt, Classes, QGraphics, QForms, QControls,
  QStdCtrls, QMenus, QDialogs, QExtCtrls, QTypes;

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 *.xfm}

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.
MenuF.xfm
object FormColorText: TFormColorText
  Left = 270
  Top = 112
  Width = 455
  Height = 273
  Caption = 'Dynamic Menu'
  Color = clButton
  Font.CharSet = fcsLatin1
  Font.Color = clBlack
  Font.Height = 11
  Font.Name = 'MS Sans Serif'
  Font.Pitch = fpVariable
  Font.Style = []
  Font.Weight = 40
  Menu = MainMenu1
  ParentFont = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  TextWidth = 6
  object Label1: TLabel
    Left = 0
    Top = 0
    Width = 455
    Height = 250
    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 = fcsLatin1
    Font.Color = clNavy
    Font.Height = 37
    Font.Name = 'Arial'
    Font.Pitch = fpVariable
    Font.Style = []
    Font.Weight = 40
    ParentColor = False
    ParentFont = False
    WordWrap = True
  end
  object ColorDialog1: TColorDialog
    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.Color = clText
    Font.Height = 13
    Font.Name = 'System'
    Font.Pitch = fpVariable
    Font.Style = []
    Font.Weight = 40
    Left = 32
    Top = 16
  end
end