Пунктирная линия

← →
I m A © (2004-12-12 04:48) [0]

как сделать так, чтобы штрихи были одной длины не зависимо от скорости и угла движения мыши... если у кого есть другие идеи... делитесь... :) буду признательна за любую помощь.
var
Flag: Boolean;
Pt: TPoint;

{$R *.dfm}

procedure TForm1.imMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var i,j:integer;
begin
if Flag then
begin
with Im do //im - image
begin
canvas.Pen.Width:=1;
j:=(x+y)mod 8;
if (j>=2) and (j<=4) then begin
Canvas.Brush.Style := bsClear;
canvas.MoveTo(x,y);
end
else begin
canvas.Brush.Style:=bssolid;
Canvas.Pen.Style := pssolid;
Canvas.LineTo(X, Y);
end;
end;
end;
end;

procedure TForm1.imMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
Flag := True;
Pt := Point(X, Y);
with Im do
begin
// Canvas.Pen.Color:=clwhite;
Canvas.MoveTo(X, Y);
end;
end;
end;

procedure TForm1.imMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Flag then
begin
Flag := False;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
form1.DoubleBuffered:=true;
end;

end.

← →
Mihey_temporary © (2004-12-12 20:09) [1]

Нужно использовать LineDDA и немного математики.

unit mainUnit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TmainForm = class(TForm) procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormCreate(Sender: TObject); procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } public { Public declarations } end; const Dash: Integer = 10; var mainForm: TmainForm; lastKey: TPoint; DoDash: Boolean; DashCasche: TPoint; procedure DrawPointOfLine(x, y: Integer; lpData: LParam); stdcall; implementation {$R *.DFM} procedure DrawPointOfLine(x, y: Integer; lpData: LParam); begin with TObject(lpData) as TmainForm do begin If Round(Sqrt(Sqr(X - lastKey.X) + Sqr(Y - lastKey.Y))) < Dash then Exit else begin if DoDash then begin Canvas.MoveTo(lastKey.X, lastKey.Y); Canvas.LineTo(x, y); lastKey := Point(x, y); DoDash := False; end else begin lastKey := Point(x, y); DoDash := True; end; end; end; end; procedure TmainForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if ssLeft in Shift then begin // Если в радиусе Dash, то не рисуем if Round(Sqrt(Sqr(X - lastKey.X) + Sqr(Y - lastKey.Y))) < Dash then Exit else begin LineDDA(lastKey.X, lastKey.Y, X, Y, @DrawPointOfLine, Integer(Self)); end; end; end; procedure TmainForm.FormCreate(Sender: TObject); begin lastKey := Point(-1, -1); end; procedure TmainForm.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin lastKey := Point(X, Y); end; procedure TmainForm.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin lastKey := Point(-1, -1); end; end.

Исходник с откомпилированным проектом:
http://www.hot.ee/mvps15/LineDraw.rar
Скриншот программы в действии:
http://www.hot.ee/mvps15/screen1.png

← →
I m A © (2004-12-15 01:03) [2]

Большое спасибо, Михаил ;)

← →
I m A © (2004-12-15 04:17) [3]

Вот только возникла маленькая загвостка :(
я немного модернизировала Ваш код так, чтобы он рисовал на имаджине...
поменяла процедуры и with TObject(lpData) as TmainForm do begin
на TImage...
но в строке
if Round(Sqrt(Sqr(X - lastKey.X) + Sqr(Y - lastKey.Y))) < Dash then
Exit else begin linedda(lastKey.X, lastKey.Y, X, Y, @DrawPointOfLine, Integer(Self));

выдается ошибка
statment expected, but expression of type "TSpeedButton" found

а если не менять Tmainform, то он вообще не рисует...
подскажите, может я что-то где-то упустила :(

← →
I m A © (2004-12-15 06:20) [4]

разобралась

блин... :(((((
опять та же феня

Ну вот как для TImage можно изменить:
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TForm1 = class(TForm) Image1: TImage; procedure FormCreate(Sender: TObject); procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } public { Public declarations } end; const Dash2: Integer = Sqr(10); var Form1: TForm1; lastKey: TPoint; DoDash: Boolean; DashCasche: TPoint; implementation {$R *.dfm} procedure DrawPointOfLine(x, y: Integer; lpData: LParam); stdcall; begin with TImage(lpData) do begin if Sqr(X - lastKey.X) + Sqr(Y - lastKey.Y) < Dash2 then Exit else begin if DoDash then begin Canvas.MoveTo(lastKey.X, lastKey.Y); Canvas.LineTo(x, y); lastKey := Point(x, y); DoDash := False; end else begin lastKey := Point(x, y); DoDash := True; end; end; end; end; procedure TForm1.FormCreate(Sender: TObject); begin lastKey := Point(-1, -1); DoubleBuffered := True; end; procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if ssLeft in Shift then begin if (Sqr(X - lastKey.X) + Sqr(Y - lastKey.Y)) < Dash2 then Exit else begin LineDDA(lastKey.X, lastKey.Y, X, Y, @DrawPointOfLine, Integer(Sender)); end; end; end; procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin lastKey := Point(X, Y); end; procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin lastKey := Point(-1, -1); end; end.

Пунктирная линия Найти похожие ветки