Project BMPDRAW
Project Structure
BMPDRAW.DPR
program BmpDraw;
uses
Forms,
BmpForm in 'BmpForm.pas' {BitmapForm};
{$R *.RES}
begin
Application.CreateForm(TBitmapForm, BitmapForm);
Application.Run;
end.
BMPFORM.PAS
unit BmpForm;
interface
uses
Windows, Classes, Graphics, Forms, Controls, Menus,
Dialogs, StdCtrls, ExtCtrls, SysUtils, ComCtrls, Buttons;
type
TBitmapForm = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
Help1: TMenuItem;
AboutImageViewer1: TMenuItem;
OpenDialog1: TOpenDialog;
Options1: TMenuItem;
Image1: TImage;
ColorDepth1: TMenuItem;
GenerateSlow1: TMenuItem;
GenerateFast1: TMenuItem;
ScrollPanel1: TMenuItem;
PanelScroll: TPanel;
TrackBar1: TTrackBar;
BtnCancel: TBitBtn;
BtnGo: TBitBtn;
Label1: TLabel;
procedure Open1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure AboutImageViewer1Click(Sender: TObject);
procedure ColorDepth1Click(Sender: TObject);
procedure GenerateSlow1Click(Sender: TObject);
procedure GenerateFast1Click(Sender: TObject);
procedure ScrollPanel1Click(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure BtnGoClick(Sender: TObject);
procedure BtnCancelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
nLines: Integer;
fCancel: Boolean;
public
{ Public declarations }
end;
var
BitmapForm: TBitmapForm;
implementation
{$R *.DFM}
procedure TBitmapForm.Open1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Image1.Picture.LoadFromFile (OpenDialog1.FileName);
Caption := 'Image Viewer - ' + OpenDialog1.FileName;
end;
end;
procedure TBitmapForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TBitmapForm.AboutImageViewer1Click(Sender: TObject);
begin
MessageDlg ('Image Viewer is an example'
+ #13'of the book "Mastering Delphi"'
+ #13'written by Marco Cantù',
mtInformation, [mbOk], 0);
end;
procedure TBitmapForm.ColorDepth1Click(Sender: TObject);
var
strDepth: String;
begin
case Image1.Picture.Bitmap.PixelFormat of
pfDevice: strDepth := 'Device';
pf1bit: strDepth := '1-bit';
pf4bit: strDepth := '4-bit';
pf8bit: strDepth := '8-bit';
pf15bit: strDepth := '15-bit';
pf16bit: strDepth := '16-bit';
pf24bit: strDepth := '24-bit';
pf32bit: strDepth := '32-bit';
pfCustom: strDepth := 'Custom';
end;
MessageDlg ('Bitmap color depth: ' + strDepth,
mtInformation, [mbOK], 0);
end;
procedure TBitmapForm.GenerateSlow1Click(Sender: TObject);
var
Bmp: TBitmap;
I, J: Integer;
T: Cardinal;
begin
// get the image and modify it
Bmp := Image1.Picture.Bitmap;
Bmp.PixelFormat := pf24bit;
Bmp.Width := 256;
Bmp.Height := 256;
T := GetTickCount;
// change every pixel
for I := 0 to Bmp.Height - 1 do
for J := 0 to Bmp.Width - 1 do
Bmp.Canvas.Pixels [I, J] := RGB (I*J mod 255, I, J);
Caption := 'Image Viewer - Memory Image (MSecs: ' +
IntToStr (GetTickCount - T) + ')';
end;
procedure TBitmapForm.GenerateFast1Click(Sender: TObject);
var
Bmp: TBitmap;
I, J: Integer;
T: Cardinal;
Line: PByteArray;
begin
// get the image and modify it
Bmp := Image1.Picture.Bitmap;
Bmp.PixelFormat := pf24bit;
Bmp.Width := 256;
Bmp.Height := 256;
T := GetTickCount;
// change every pixel, line by line
for I := 0 to Bmp.Height - 1 do
begin
Line := PByteArray (Bmp.ScanLine [I]);
for J := 0 to Bmp.Width - 1 do
begin
Line [J*3] := J;
Line [J*3+1] := I*J mod 255;
Line [J*3+2] := I;
end;
end;
// refresh the video
Image1.Invalidate;
Caption := 'Image Viewer - Memory Image (MSecs: ' +
IntToStr (GetTickCount - T) + ')';
end;
procedure TBitmapForm.ScrollPanel1Click(Sender: TObject);
begin
PanelScroll.Visible := not PanelScroll.Visible;
ScrollPanel1.Checked := PanelScroll.Visible;
end;
procedure TBitmapForm.TrackBar1Change(Sender: TObject);
begin
nLines := TrackBar1.Position;
TrackBar1.Hint := IntToStr (TrackBar1.Position);
end;
procedure TBitmapForm.BtnGoClick(Sender: TObject);
var
W, H, I, J, LineBytes: Integer;
Line: PByteArray;
Bmp: TBitmap;
R: TRect;
begin
// set the user interface
fCancel := False;
BtnGo.Enabled := False;
BtnCancel.Enabled := True;
// get the bitmap of the image and resize it
Bmp := Image1.Picture.Bitmap;
W := Bmp.Width;
H := Bmp.Height;
// allocate enough memory for one line
LineBytes := Abs (Integer (Bmp.ScanLine [1]) -
Integer (Bmp.ScanLine [0]));
Line := AllocMem (LineBytes);
// scroll how many itmes as there are lines
for I := 0 to H - 1 do
begin
// exit the for loop if Cancel was pressed
if fCancel then
Break;
// copy the first line
Move ((Bmp.ScanLine [0])^, Line^, LineBytes);
// for every line
for J := 1 to H - 1 do
begin
// move line to the previous one
Move ((Bmp.ScanLine [J])^, (Bmp.ScanLine [J-1])^, LineBytes);
// every nLines update the output
if (J mod nLines = 0) then
begin
R := Rect (0, PanelScroll.Height + J-nLines,
W, PanelScroll.Height + J);
InvalidateRect (Handle, @R, False);
UpdateWindow (Handle);
end;
end;
// move back the first line to the end
Move (Line^, (Bmp.ScanLine [Bmp.Height - 1])^, LineBytes);
// update the final portion of the bitmap
R := Rect (0, PanelScroll.Height + H - nLines,
W, PanelScroll.Height + H);
InvalidateRect (Handle, @R, False);
UpdateWindow (Handle);
// let the program handle other messages
Application.ProcessMessages;
end;
// reset the UI
BtnGo.Enabled := True;
BtnCancel.Enabled := False;
end;
procedure TBitmapForm.BtnCancelClick(Sender: TObject);
begin
fCancel := True;
end;
procedure TBitmapForm.FormCreate(Sender: TObject);
begin
TrackBar1Change (Self);
end;
end.
BMPFORM.DFM
object BitmapForm: TBitmapForm
Left = 245
Top = 131
Width = 475
Height = 385
Caption = 'Bitmap Draw'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Arial'
Font.Style = []
Menu = MainMenu1
OldCreateOrder = True
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 16
object Image1: TImage
Left = 0
Top = 49
Width = 467
Height = 290
Align = alClient
end
object PanelScroll: TPanel
Left = 0
Top = 0
Width = 467
Height = 49
Align = alTop
ParentShowHint = False
ShowHint = True
TabOrder = 0
Visible = False
object Label1: TLabel
Left = 216
Top = 16
Width = 41
Height = 16
Caption = 'Speed:'
end
object TrackBar1: TTrackBar
Left = 264
Top = 9
Width = 150
Height = 31
Max = 210
Min = 10
Orientation = trHorizontal
PageSize = 40
Frequency = 20
Position = 110
SelEnd = 0
SelStart = 0
TabOrder = 0
TickMarks = tmBottomRight
TickStyle = tsAuto
OnChange = TrackBar1Change
end
object BtnCancel: TBitBtn
Left = 104
Top = 11
Width = 75
Height = 25
Caption = '&Cancel'
Enabled = False
TabOrder = 1
OnClick = BtnCancelClick
Kind = bkCancel
end
object BtnGo: TBitBtn
Left = 16
Top = 11
Width = 75
Height = 25
Caption = '&Go'
TabOrder = 2
OnClick = BtnGoClick
Kind = bkIgnore
end
end
object MainMenu1: TMainMenu
Left = 24
Top = 56
object File1: TMenuItem
Caption = '&File'
object Open1: TMenuItem
Caption = '&Open...'
OnClick = Open1Click
end
object N1: TMenuItem
Caption = '-'
end
object Exit1: TMenuItem
Caption = '&Exit'
OnClick = Exit1Click
end
end
object Options1: TMenuItem
Caption = '&Options'
object ColorDepth1: TMenuItem
Caption = 'Color &Depth'
OnClick = ColorDepth1Click
end
object GenerateSlow1: TMenuItem
Caption = '&Generate (Slow)'
OnClick = GenerateSlow1Click
end
object GenerateFast1: TMenuItem
Caption = 'Generate (&Fast)'
OnClick = GenerateFast1Click
end
object ScrollPanel1: TMenuItem
Caption = 'Scroll Panel'
OnClick = ScrollPanel1Click
end
end
object Help1: TMenuItem
Caption = '&Help'
object AboutImageViewer1: TMenuItem
Caption = '&About Bitmap Draw...'
OnClick = AboutImageViewer1Click
end
end
end
object OpenDialog1: TOpenDialog
Filter = 'Bitmap (*.bmp)|*.bmp'
Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist]
Left = 24
Top = 104
end
end
|
Home:
Code Repository:
Mastering Delphi 5