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.