Приложение
Листинг программы
unit Pazle;
interface
uses
windows, SysUtils, Classes, Controls, graphics, Dialogs, forms, StdCtrls,
Messages, ExtCtrls;
type
TPazle = class(TCustomControl)
private
FColCount: integer;
FRowCount: integer;
FCut: boolean;
FBitmap:TBitmap;
procedure SetColCount(const Value: integer);
procedure SetRowCount(const Value: integer);
procedure SetCut(const Value: boolean);
procedure SetBitmap(const Value: TBitmap);
protected
procedure Paint; override;
procedure CheckRight;
public
Complete:boolean;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Bitmap: TBitmap read FBitmap write SetBitmap;
property ColCount: integer read FColCount write SetColCount;
property RowCount: integer read FRowCount write SetRowCount;
property Cut: boolean read FCut write SetCut;
end;
TPiece = class(TCustomControl)
private
FX: Integer;
FY: Integer;
protected
procedure WMNCHitTest(var Message:TMessage); message WM_NCHITTEST;
procedure Paint; override;
function IsOnPlace:Boolean;
procedure WMMOVE(var Message:TMessage); message WM_MOVE;
public
property X:Integer read FX write FX;
property Y:Integer read FY write FY;
published
end;
procedure Register;
implementation
uses Variants, Types;
procedure Register;
begin
RegisterComponents('Game', [TPazle, TPiece]);
end;
var
lPiece:TPiece;
{ TPazle }
procedure TPazle.CheckRight;
var
i:integer;
a:boolean;
begin
a:=true;
for i:= ComponentCount - 1 downto 0 do
begin
with Components[i] as TPiece do
begin
a:=a and IsOnPlace;
end;
end;
if a then
Complete:=true;
end;
constructor TPazle.Create(AOwner: TComponent);
begin
inherited;
width := 300;
Height := 300;
color:=clGray;
FBitmap:=TBitmap.Create;
FColCount := 2;
FRowCount := 2;
Cut := False;
end;
destructor TPazle.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TPazle.Paint;
begin
inherited;
if not FCut then
Canvas.StretchDraw(ClientRect, FBitmap);
canvas.Brush.Color:=clBlack;
Canvas.FrameRect(ClientRect);
if Complete and lPiece.IsOnPlace then
ShowMessage('Сейчас рисунок собран правильно!');
Complete:=false;
end;
procedure TPazle.SetBitmap(const Value: TBitmap);
begin
FBitMap.Assign(Value);
Invalidate;
end;
procedure TPazle.SetColCount(const Value: integer);
begin
FColCount := Value;
end;
procedure TPazle.SetCut(const Value: boolean);
var
c, r: integer;
dx,dy:Integer;
begin
FCut := Value;
if Cut then
begin // Нарезаем кусочки
dx:=ClientWidth div ColCount;
dy:=ClientHeight div RowCount;
for c := 0 to ColCount - 1 do
for r := 0 to RowCount - 1 do
begin
lPiece := TPiece.Create(self);
lPiece.Parent := self;
lPiece.Width:=dx;
lPiece.Height:=dy;
lPiece.X:=C;
lPiece.Y:=R;
lPiece.Left:= Random(ClientWidth);
lPiece.Top:= Random(ClientHeight);
end;
end
else
begin
for c := ComponentCount - 1 downto 0 do
Components[c].Free;
end;
Invalidate;
end;
procedure TPazle.SetRowCount(const Value: integer);
begin
FRowCount := Value;
end;
{ TPiece }
function TPiece.IsOnPlace: Boolean;
begin
Result:=(Left=(X*ClientWidth)) and (top=(Y*ClientHeight));
end;
procedure TPiece.Paint;
var dx, dy:Integer;
begin
inherited;
Canvas.Brush.Color:=clBlack;
dx:=TPazle(Owner).FBitmap.Width div TPazle(Owner).ColCount;
dy:=TPazle(Owner).FBitmap.Height div TPazle(Owner).RowCount;
Canvas.CopyRect(ClientRect,TPazle(Owner).FBitmap.Canvas, Rect(dx*x,dy*y, dx*(x+1), dy*(y+1)));
Canvas.FrameRect(ClientRect);
end;
procedure TPiece.WMMOVE(var Message: TMessage);
var
xx,yy:integer;
begin
xx:=X*ClientWidth;
yy:=Y*ClientHeight;
if abs(Message.LParamLo-xx)<=8 then Left:=xx; //автовыравнивание
if abs(Message.LParamHi-yy)<=8 then top:=yy; //
IsOnPlace;
TPazle(owner).CheckRight;
end;
procedure TPiece.WMNCHitTest(var Message: TMessage);
begin
Message.Result :=
DefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam);
if Message.Result=HTCLIENT then Message.Result:=HTCaption;
end;
end.