Demo: 模仿画图程序的选块另存为功能
Demo: 模仿画图程序的选块另存为功能
分类： 编程笔记 2007-06-16 10:31
转自：http://rabbitfox.blog.sohu.com/50812083.html
(****************************************
单元名称: 模仿画图程序的选块另存为功能
作 者: LihuaSoft
编码日期: 2007年6月16日
说 明: 因此程序是演示程序, 只允许使用
BMP格式图片
*****************************************)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg, Menus;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
PopupMenu1: TPopupMenu;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Bmp : TBitmap;
rFrom, rTo : TRect;
CanSelect : boolean;
MenuItemSaveAs : TMenuItem;
procedure SelectedSaveAs(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := '演示：导入一幅BMP后，拖动鼠标左键选择一块区域，右键另存为';
Button1.Caption := '导入BMP';
Image1.Left := 0;
Image1.Top := 0;
Image1.AutoSize := True;
OpenDialog1.FileName := '*.BMP';
OpenDialog1.Filter := 'Windows位图文件';
SaveDialog1.FileName := '*.BMP';
SaveDialog1.Filter := '请输入欲存为的BMP文件名';
MenuItemSaveAs := TMenuItem.Create(PopupMenu1);
MenuItemSaveAs.Caption := '选区另存为BMP文件';
MenuItemSaveAs.OnClick := SelectedSaveAs;
PopupMenu1.Items.Add(MenuItemSaveAs);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
if Bmp<>nil then FreeAndNil(Bmp);
Bmp := TBitmap.Create;
Bmp.LoadFromFile(OpenDialog1.FileName);
with Image1 do begin
Picture.Bitmap := Bmp;
Canvas.Pen.Mode := pmNot;
Canvas.Brush.Style := bsClear;
OnMouseDown := Image1MouseDown;
OnMouseMove := Image1MouseMove;
OnMouseUp := Image1MouseUp;
end;
rFrom := Rect(0, 0, 0, 0);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Bmp<>nil then FreeAndNil(Bmp);
if MenuItemSaveAs<>nil then FreeAndNil(MenuItemSaveAs);
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
CanSelect := True;
if (rFrom.Left<>rFrom.Right) and (rFrom.Top<>rFrom.Bottom) then
Image1.Canvas.Rectangle(rFrom);
rFrom.Left := X;
rFrom.Top := Y;
rFrom.Right := X;
rFrom.Bottom := Y;
end;
if Button = mbRight then
if (rFrom.Left<>rFrom.Right) and (rFrom.Top<>rFrom.Bottom) then
PopupMenu1.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if CanSelect then begin
Image1.Canvas.Rectangle(rFrom);
rFrom.Right := X;
rFrom.Bottom := Y;
Image1.Canvas.Rectangle(rFrom);
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
CanSelect := False;
end;
procedure TForm1.SelectedSaveAs(Sender: TObject);
var
TempBmp : TBitmap;
begin
if SaveDialog1.Execute then begin
TempBmp := TBitmap.Create;
try
TempBmp.Width := rFrom.Right-rFrom.Left;
TempBmp.Height := rFrom.Bottom-rFrom.Top;
rTo := Rect(0, 0, TempBmp.Width, TempBmp.Height);
TempBmp.Canvas.CopyRect(rTo, Bmp.Canvas, rFrom);
TempBmp.SaveToFile(SaveDialog1.FileName);
finally
TempBmp.Free;
end;
end;
end;
end.
======================
2008年9月2日新增适用JPG格式代码：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg, Menus;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
PopupMenu1: TPopupMenu;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Bmp : TBitmap;
Jpg : TJpegImage;
rFrom, rTo : TRect;
CanSelect : boolean;
MenuItemSaveAs : TMenuItem;
procedure SelectedSaveAs(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := '演示：导入一幅JPG后，拖动鼠标左键选择一块区域，右键另存为';
Button1.Caption := '导入JPG';
Image1.Left := 0;
Image1.Top := 0;
Image1.AutoSize := True;
OpenDialog1.FileName := '*.JPG';
OpenDialog1.Filter := 'Jpeg格式文件';
SaveDialog1.FileName := '*.JPG';
SaveDialog1.Filter := '请输入欲存为的JPG文件名';
MenuItemSaveAs := TMenuItem.Create(PopupMenu1);
MenuItemSaveAs.Caption := '选区另存为JPG文件';
MenuItemSaveAs.OnClick := SelectedSaveAs;
PopupMenu1.Items.Add(MenuItemSaveAs);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
if not Assigned(Bmp) then Bmp := TBitmap.Create;
if not Assigned(Jpg) then Jpg := TJpegImage.Create;
Jpg.LoadFromFile(OpenDialog1.FileName);
Bmp.Assign(Jpg);
with Image1 do begin
Picture.Bitmap := Bmp;
Canvas.Pen.Mode := pmNot;
Canvas.Brush.Style := bsClear;
OnMouseDown := Image1MouseDown;
OnMouseMove := Image1MouseMove;
OnMouseUp := Image1MouseUp;
end;
rFrom := Rect(0, 0, 0, 0);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Bmp<>nil then FreeAndNil(Bmp);
if Jpg<>nil then FreeAndNil(Jpg);
if MenuItemSaveAs<>nil then FreeAndNil(MenuItemSaveAs);
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
CanSelect := True;
if (rFrom.Left<>rFrom.Right) and (rFrom.Top<>rFrom.Bottom) then
Image1.Canvas.Rectangle(rFrom);
rFrom.Left := X;
rFrom.Top := Y;
rFrom.Right := X;
rFrom.Bottom := Y;
end;
if Button = mbRight then
if (rFrom.Left<>rFrom.Right) and (rFrom.Top<>rFrom.Bottom) then
PopupMenu1.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if CanSelect then begin
Image1.Canvas.Rectangle(rFrom);
rFrom.Right := X;
rFrom.Bottom := Y;
Image1.Canvas.Rectangle(rFrom);
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
CanSelect := False;
end;
procedure TForm1.SelectedSaveAs(Sender: TObject);
var
TempBmp : TBitmap;
TempJpg : TJpegImage;
begin
if SaveDialog1.Execute then begin
TempBmp := TBitmap.Create;
TempJpg := TJpegImage.Create;
try
TempBmp.Width := rFrom.Right-rFrom.Left;
TempBmp.Height := rFrom.Bottom-rFrom.Top;
rTo := Rect(0, 0, TempBmp.Width, TempBmp.Height);
TempBmp.Canvas.CopyRect(rTo, Bmp.Canvas, rFrom);
TempJpg.Assign(TempBmp);
TempJpg.SaveToFile(SaveDialog1.FileName);
finally
TempJpg.Free;
TempBmp.Free;
end;
end;
end;
end.
