Demo: 模仿画图程序的选块另存为功能
分类： 2007-06-16 10:31
转自：
(**************************************** 单元名称: 模仿画图程序的选块另存为功能 作 者: 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.