Das Programm funktioniert aber ruft das Paintbox.onPaint irgendwie zirkulär auf. (Der Debugserver bekommt in einer Tour "Painiting" obwohl die Maus gar nicht bewegt wird. Danz ganze pausiert erst dann, wenn man die Maus aus der Paintbox rausschiebt. Ich muss aber auf die Bewegung der Maus mit neuzeichnen der Paintbox reagieren.
Code: Alles auswählen
unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
msetypes,mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
msegraphics,msegraphutils,mseevent,mseclasses,msewidgets,mseforms,msedock,
msedockpanelform,msesimplewidgets, dbugintf;
type
tmymousehandler = class
private
startx, starty,
fx, fy : integer;
fdown : boolean;
public
procedure mymousemove(sender : twidget; var ainfo : mouseeventinfoty);
procedure mymousedown(sender : tobject; var ainfo : mouseeventinfoty);
procedure mymouseup(sender : tobject; var ainfo : mouseeventinfoty);
procedure mymousehandler(const sender : twidget; var ainfo : mouseeventinfoty);
procedure mypaint(sender : tobject; Canvas : TCanvas);
end;
tmainfo = class(tdockpanelform)
pb: tpaintbox;
procedure formcreate(const sender: TObject);
procedure pbpaint(const sender: twidget; const acanvas: tcanvas);
private
fHandler : tmymousehandler;
end;
var
mainfo: tmainfo;
implementation
uses
main_mfm;
{ tmymousehandler }
procedure tmymousehandler.mymousemove(sender: twidget;
var ainfo: mouseeventinfoty);
begin
fx := ainfo.pos.x;
fy := ainfo.pos.y;
sender.invalidate;
end;
procedure tmymousehandler.mymousedown(sender: tobject;
var ainfo: mouseeventinfoty);
begin
fdown := true;
startx := ainfo.pos.x;
starty := ainfo.pos.y;
end;
procedure tmymousehandler.mymouseup(sender: tobject;
var ainfo: mouseeventinfoty);
begin
fdown := false;
end;
procedure tmymousehandler.mymousehandler(const sender: twidget;
var ainfo: mouseeventinfoty);
begin
case ainfo.eventkind of
ek_mousemove : mymousemove(sender, ainfo);
ek_buttonpress : mymousedown(sender, ainfo);
ek_buttonrelease : mymouseup(sender, ainfo);
end;
end;
procedure tmymousehandler.mypaint(sender: tobject; Canvas: TCanvas);
begin
SendDebug('painting');
if fdown then
begin
canvas.color := cl_black;
canvas.drawline(mp(startx, starty), mp(fx, fy));
end;
end;
procedure tmainfo.formcreate(const sender: TObject);
begin
fHandler := TMyMouseHandler.Create;
pb.onmouseevent := @fhandler.mymousehandler;
end;
procedure tmainfo.pbpaint(const sender: twidget; const acanvas: tcanvas);
begin
fhandler.mypaint(sender, acanvas);
end;
end.