Marco Cantù 1998, Mastering Delphi 4
Project: BITMENU.DPR
Project Structure
BITMENU.DPR
program BitMenu;
uses
Forms,
BitMenuF in 'BitMenuF.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
BITMENUF.PAS
unit BitMenuF;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Menus;
type
TForm1 = class(TForm)
ShapeDemo: TShape;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Shape1: TMenuItem;
Ellipse1: TMenuItem;
RoundRec1: TMenuItem;
Rectang1: TMenuItem;
Color1: TMenuItem;
Red1: TMenuItem;
Green1: TMenuItem;
Blue1: TMenuItem;
Help1: TMenuItem;
About1: TMenuItem;
procedure FormResize(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure Red1Click(Sender: TObject);
procedure Green1Click(Sender: TObject);
procedure Blue1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Ellipse1Click(Sender: TObject);
procedure RoundRec1Click(Sender: TObject);
procedure Rectang1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormResize(Sender: TObject);
begin
ShapeDemo.SetBounds (ClientWidth div 6, ClientHeight div 6,
2 * ClientWidth div 3, 2 * ClientHeight div 3);
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.About1Click(Sender: TObject);
begin
MessageDlg ('Bitmap Menu example,'#13 +
'from "Mastering Delphi" by Marco Cantù',
mtInformation, [mbOK], 0);
end;
procedure TForm1.Red1Click(Sender: TObject);
begin
ShapeDemo.Brush.Color := clRed;
end;
procedure TForm1.Green1Click(Sender: TObject);
begin
ShapeDemo.Brush.Color := clLime;
end;
procedure TForm1.Blue1Click(Sender: TObject);
begin
ShapeDemo.Brush.Color := clBlue;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
Bmp: TBitmap;
begin
// load the bitmaps for the shapes
for I := 0 to Shape1.Count - 1 do
begin
Bmp := TBitmap.Create;
Bmp.LoadFromFile (Shape1.Items [I].Caption + '.bmp');
ModifyMenu (Shape1.Handle,
Shape1.Items [I].MenuIndex,
mf_ByPosition or mf_Bitmap,
Shape1.Items [I].Command,
Pointer (Bmp.Handle));
Shape1.Items [I].Tag := Integer (Bmp);
end;
// load the bitmaps for the colors
for I := 0 to Color1.Count - 1 do
begin
Bmp := TBitmap.Create;
Bmp.LoadFromFile (Color1.Items [I].Caption + '.bmp');
ModifyMenu (Color1.Handle,
Color1.Items [I].MenuIndex,
mf_ByPosition or mf_Bitmap,
Color1.Items [I].Command,
Pointer (Bmp.Handle));
Color1.Items [I].Tag := Integer (Bmp);
end;
end;
procedure TForm1.Ellipse1Click(Sender: TObject);
begin
ShapeDemo.Shape := stEllipse;
end;
procedure TForm1.RoundRec1Click(Sender: TObject);
begin
ShapeDemo.Shape := stRoundRect;
end;
procedure TForm1.Rectang1Click(Sender: TObject);
begin
ShapeDemo.Shape := stRectangle;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
I: Integer;
begin
for I := 0 to Shape1.Count - 1 do
TBitmap (Shape1.Items [I].Tag).Free;
for I := 0 to Color1.Count - 1 do
TBitmap (Color1.Items [I].Tag).Free;
end;
end.
BITMENUF.DFM
object Form1: TForm1
Left = 200
Top = 112
Width = 425
Height = 298
Caption = 'Bitmap Menu'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Menu = MainMenu1
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object ShapeDemo: TShape
Left = 104
Top = 72
Width = 145
Height = 81
Shape = stEllipse
end
object MainMenu1: TMainMenu
Left = 56
Top = 16
object File1: TMenuItem
Caption = '&File'
object Exit1: TMenuItem
Caption = 'E&xit'
OnClick = Exit1Click
end
end
object Shape1: TMenuItem
Caption = '&Shape'
object Ellipse1: TMenuItem
Caption = 'Ellipse'
OnClick = Ellipse1Click
end
object RoundRec1: TMenuItem
Caption = 'RoundRec'
OnClick = RoundRec1Click
end
object Rectang1: TMenuItem
Caption = 'Rectang'
OnClick = Rectang1Click
end
end
object Color1: TMenuItem
Caption = '&Color'
object Red1: TMenuItem
Caption = 'Red'
OnClick = Red1Click
end
object Green1: TMenuItem
Caption = 'Green'
OnClick = Green1Click
end
object Blue1: TMenuItem
Caption = 'Blue'
OnClick = Blue1Click
end
end
object Help1: TMenuItem
Caption = '&Help'
object About1: TMenuItem
Caption = '&About...'
OnClick = About1Click
end
end
end
end
Copyright Marco Cantù 1998