image上动态画线的问题!(17分)

  • 主题发起人 主题发起人 哦哦哦哦哦
  • 开始时间 开始时间

哦哦哦哦哦

Unregistered / Unconfirmed
GUEST, unregistred user!
我在image上画了一堆线,想让这些线动起来,但原来画的线还在上面。image没有clear属性,不能一下清除上面的内容,再重画,有什么办法吗?(我把image设为透明的)
 
//看看这个对你会不会有所帮助

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.
 
接受答案了.
 
后退
顶部