Текущий архив: 2005.03.27;
Скачать: CL | DM;

Вниз

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

← →
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]

разобралась

---

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

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

---

← →
MBo ©   (2004-12-15 07:16) [6]

Ну вот как для 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.



---

Страницы: 1 вся ветка

Текущий архив: 2005.03.27;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.178 c