unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ExtDlgs, Jpeg, Math;
type
TForm1 = class(TForm)
btnLoadFile: TButton;
pl: TPanel;
OD: TOpenDialog;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure btnLoadFileClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TmImage = class(TCustomControl)
private
FSRect: TRect;
FSr: TBitmap;
FBmp: TBitmap;
FDown: Boolean;
procedure WMLButtonDown(var message: TWMMouse); message WM_LButtonDown;
procedure WMLButtonUp(var message: TWMMouse); message WM_LButtonUp;
procedure WMMouseMove(var message: TWMMouse); message WM_MouseMove;
procedure WMSize(var message: TWMSize); message WM_Size;
procedure WMPaint(var message: TWMPaint); message WM_Paint;
procedure WMERASEBKGND(var message: TMessage); message WM_ERASEBKGND;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure GetFile(fn: string);
end;
var
Form1: TForm1;
mI: TmImage;
implementation
{$R *.dfm}
{ TmImage }
constructor TmImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
SetRectEmpty(FSRect);
FBmp := TBitmap.Create;
FSr := TBitmap.Create;
FBmp.Canvas.Pen.Style := psDot;
FBmp.Canvas.Pen.Color := clRed;
FBmp.Canvas.Brush.Style := bsClear;
FBmp.Width := Width;
FBmp.Height := Height;
FSr.Width := Width;
FSr.Height := Height;
FDown := false;
end;
destructor TmImage.Destroy;
begin
FreeAndNil(FBmp);
FreeAndNil(FSr);
inherited;
end;
procedure TmImage.GetFile(fn: string);
begin
FSr.LoadFromFile(fn);
Repaint;
end;
procedure TmImage.WMERASEBKGND(var message: TMessage);
begin
message.Result := 1;
end;
procedure TmImage.WMLButtonDown(var message: TWMMouse);
begin
inherited;
FSRect.Top := message.YPos;
FSRect.Left := message.XPos;
FDown := true;
end;
procedure TmImage.WMLButtonUp(var message: TWMMouse);
begin
inherited;
if not FDown then exit;
Repaint;
FDown := false;
SetRectEmpty(FSRect);
end;
procedure TmImage.WMMouseMove(var message: TWMMouse);
var
temp: integer;
begin
inherited;
if not FDown then exit;
FSRect.Bottom := message.YPos;
FSRect.Right := message.XPos;
Repaint;
end;
procedure TmImage.WMPaint(var message: TWMPaint);
var
DestDC, SrcDC: HDC;
w, h: integer;
begin
inherited;
DestDC := FBmp.Canvas.Handle;
SrcDC := FSr.Canvas.Handle;
w := FSr.Width;
h := FSr.Height;
BitBlt(DestDC, 0, 0, w, h, SrcDC, 0, 0, SRCCOPY );
FBmp.Canvas.Rectangle(FSRect);
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBmp.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TmImage.WMSize(var message: TWMSize);
begin
inherited;
FBmp.Width := message.Width;
FSr.Width := message.Width;
FBmp.Height := message.Height;
FSr.Height := message.Height;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
mI := TmImage.Create(nil);
mI.Parent := pl;
mI.Align := alClient;
end;
procedure TForm1.btnLoadFileClick(Sender: TObject);
begin
if (OD.Execute) then
begin
mI.GetFile(OD.FileName);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(mI);
end;
end.