测试简图:

---

功能简介:
1、双击左窗口可打开源图像;
2、框选左窗口可把图像选取复制到右窗口;
3、剪取的图块可以移动, 可配合 Ctrl 单选或多选, 可用 Delete 删除选择的图块;
4、双击右窗口可保存拼好的图像.

---

功能实现:
1、MoveImage 主要完成 "图块" 的功能;
2、ImageBox 主要完成源图像及选取功能;
3、其他有主模块 Unit1 完成.

---

窗体:

---

object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 350
ClientWidth = 671
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnKeyUp = FormKeyUp
PixelsPerInch = 96
TextHeight = 13object Splitter1: TSplitter
Left = 361
Top = 0
Height = 350
ExplicitLeft = 272
ExplicitTop = 128
ExplicitHeight = 100endobject ScrollBox1: TScrollBox
Left = 0
Top = 0
Width = 361
Height = 350
Align = alLeft
TabOrder = 0
OnClick = ScrollBox1Click
OnDblClick = ScrollBox1DblClick
ExplicitHeight = 328object Image1: TImage
Left = 3
Top = 3
Width = 25
Height = 25
OnMouseEnter = Image1MouseEnterendendend

---

Unit1:

---

unitUnit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, ExtDlgs, MoveImage, ImageBox;

type
TForm1 = class(TForm)
ScrollBox1: TScrollBox;
Splitter1: TSplitter;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Image1MouseEnter(Sender: TObject);
procedure ScrollBox1Click(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ScrollBox1DblClick(Sender: TObject);
end;

var
Form1: TForm1;
ImageBox1: TImageBox;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
ImageBox1 := TImageBox.Create(Self);
with ImageBox1 do begin
Parent := Self;
Align := alClient;
OutImage := Image1;
end;
ScrollBox1.Color := clWhite;
ScrollBox1.DoubleBuffered := True;
KeyPreview := True;
List := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
i: Integer;
begin
for i := 0 to List.Count - 1 do TMoveImage(List[i]).Free;
List.Free;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var
i: Integer;
begin
if Key = VK_DELETE then for i := List.Count - 1 downto 0 do
if TMoveImage(List[i]).Selected then
begin
TMoveImage(List[i]).Free;
List.Delete(i);
end;
end;

procedure TForm1.Image1MouseEnter(Sender: TObject);
var
mi: TMoveImage;
begin
Image1.Visible := False;
mi := TMoveImage.Create(ScrollBox1);
with mi do begin
Parent := ScrollBox1;
Left := Image1.Left;
Top := Image1.Top;
Width := Image1.Width;
Height := Image1.Height;
Picture.Bitmap.Assign(Image1.Picture.Bitmap);
end;
List.Add(mi);
end;

procedure TForm1.ScrollBox1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to List.Count - 1 do
TMoveImage(List[i]).Selected := False;
end;

procedure TForm1.ScrollBox1DblClick(Sender: TObject);
var
i: Integer;
begin
with TSavePictureDialog.Create(nil) do if Execute then
begin
with TBitmap.Create do
begin
Width := ScrollBox1.HorzScrollBar.Range + 20;
Height := ScrollBox1.VertScrollBar.Range + 20;
for i := 0 to List.Count - 1 do
begin
TMoveImage(List[i]).Selected := False;
Canvas.Draw(TMoveImage(List[i]).Left,
TMoveImage(List[i]).Top,
TMoveImage(List[i]).Picture.Bitmap);
end;
SaveToFile(FileName);
Free;
end;
Free;
end;
end;

end.

---

ImageBox:

---

unitImageBox;

interface

uses
Windows, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, ExtDlgs;

type
TImageBox = class(TScrollBox)
private
FImage: TImage;
FShape: TShape;
FBitmap: TBitmap;
FFlag: Boolean;
FOutImage: TImage;
procedure SetOutImage(const Value: TImage);
protected
procedure ImageBoxDblClick(Sender: TObject);
procedure ImageBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X: Integer; Y: Integer);
procedure ImageBoxMouseMove(Sender: TObject; Shift: TShiftState;
X: Integer; Y: Integer);
procedure ImageBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X: Integer; Y: Integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap read FBitmap;
property OutImage: TImage read FOutImage write SetOutImage;
published
end;

implementation

{ TImageBox }

constructor TImageBox.Create(AOwner: TComponent);
begin
inherited;
OnDblClick := ImageBoxDblClick;
OnMouseDown := ImageBoxMouseDown;
OnMouseMove := ImageBoxMouseMove;
OnMouseUp := ImageBoxMouseUp;

FImage := TImage.Create(Self);
FImage.Parent := Self;
FImage.AutoSize := True;
FImage.OnDblClick := OnDblClick;
FImage.OnMouseDown := ImageBoxMouseDown;
FImage.OnMouseMove := ImageBoxMouseMove;
FImage.OnMouseUp := ImageBoxMouseUp;

FShape := TShape.Create(Self);
FShape.Parent := Self;
FShape.Brush.Style := bsClear;
FShape.Pen.Style := psDot;
FShape.BoundsRect := Rect(0, 0, 0, 0);
FShape.BringToFront;

FBitmap := TBitmap.Create;
end;

procedure TImageBox.ImageBoxDblClick(Sender: TObject);
begin
FFlag := False;
with TOpenPictureDialog.Create(nil) do if Execute then
begin
FImage.Picture.LoadFromFile(FileName);
Free;
end;
end;

destructor TImageBox.Destroy;
begin
FImage.Free;
FShape.Free;
FBitmap.Free;
inherited;
end;

procedure TImageBox.ImageBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
cx,cy: Integer;
begin
FFlag := True;
cx := X - HorzScrollBar.Position;
cy := Y - VertScrollBar.Position;
FShape.BoundsRect := Rect(cx, cy, cx, cy);
end;

procedure TImageBox.ImageBoxMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
cx,cy: Integer;
begin
if FFlag then
begin
cx := X - HorzScrollBar.Position;
cy := Y - VertScrollBar.Position;
if FFlag then FShape.BoundsRect := Rect(FShape.Left, FShape.Top, cx, cy);
end else
FShape.BoundsRect := Rect(0, 0, 0, 0);
end;

procedure TImageBox.ImageBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
R: TRect;
begin
if not FFlag then Exit;
FFlag := False;
if FShape.Width * FShape.Height < 100 then Exit;

if FShape.Width < 0 then
begin
FShape.Left := FShape.Left + FShape.Width;
FShape.Width := -FShape.Width;
end;
if FShape.Height < 0 then
begin
FShape.Top := FShape.Top + FShape.Height;
FShape.Height := -FShape.Height;
end;
FBitmap.Width := FShape.Width;
FBitmap.Height := FShape.Height;
R := FShape.BoundsRect;
OffsetRect(R, HorzScrollBar.Position, VertScrollBar.Position);
FBitmap.Canvas.CopyRect(FShape.ClientRect, FImage.Canvas, R);
if Assigned(FOutImage) then with FOutImage do
begin
AutoSize := True;
Picture.Bitmap.Assign(FBitmap);
Left := (Parent.ClientWidth - FOutImage.Width) div 2;
Top := (Parent.ClientHeight - Height) div 2;
Visible := True;
end;
end;

procedure TImageBox.SetOutImage(const Value: TImage);
begin
FOutImage := Value;
end;

end.

---

MoveImage:

---

unitMoveImage;

interface

uses
Windows, Classes, Graphics, Controls, ExtCtrls;

type
TMoveImage = class(TImage)
private
FFlag: Boolean;
FX,FY: Integer;
FSelected: Boolean;
procedure SetSelected(const Value: Boolean);
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
property Selected: Boolean read FSelected write SetSelected;
end;

var
List: TList;

implementation

{ TMoveImage }

constructor TMoveImage.Create(AOwner: TComponent);
begin
inherited;
Parent := TWinControl(AOwner);
Left := (TWinControl(AOwner).ClientWidth - Width) div 2;
Top := (TWinControl(AOwner).ClientHeight - Height) div 2;
end;

procedure TMoveImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FFlag := True;
FX := X;
FY := Y;
Selected := True;
end;

procedure TMoveImage.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: Integer;
begin
inherited;
if FFlag then
begin
Left := Left + X - FX;
Top := Top + Y - FY;
for i := 0 to List.Count - 1 do
if (TMoveImage(List[i]) <> Self) and (TMoveImage(List[i]).Selected) then
begin
TMoveImage(List[i]).Left := TMoveImage(List[i]).Left + X - FX;
TMoveImage(List[i]).Top := TMoveImage(List[i]).Top + Y - FY;
end;
end;
end;

procedure TMoveImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FFlag := False;
if not (ssCtrl in Shift) then
Selected := False;
end;

procedure TMoveImage.SetSelected(const Value: Boolean);
var
bit: TBitmap;
begin
if Value <> FSelected then
begin
FSelected := Value;
bit := TBitmap.Create;
bit.Width := Width;
bit.Height := Height;
BitBlt(Canvas.Handle, 0, 0, Width, Height, bit.Canvas.Handle, 0, 0, SRCINVERT);
Repaint;
bit.Free;
end;
end;

end.

本文转自黄聪博客园博客，原文链接：http://www.cnblogs.com/huangcong/archive/2010/08/27/1810014.html，如需转载请自行联系原作者