[melloun]

Доброго времени суток.
есть задание, помогите пожалуйста

Реализовать рисование так, чтобы по нажатию мыши (щелкая левой кнопкой и удерживая ее при перемещении мыши по горизонтали и вертикали) рисовались отрезки произвольной длины , а используя ту же технологию и удерживая клавишу CTRL, можно было рисовать прямоугольники различного размера .

[AND_REY]

Ниже приведен код для рисования линий, для прямоугольников
используй Rectangle.

Код:

var
 D: Boolean = False;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 D:= True;
 Form1.Canvas.MoveTo(X,Y);
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 D:= False;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if D Then Form1.Canvas.LineTo(X,Y);
end;

[melloun]

спасибо. но если можно. полностью программой отправить

[melloun]

и еще прямая рисуется только из точки (0. 0) а надо из точки фиксации

[Asinkrit]

Я думаю он хотел что-то типа этого,

рисуем прямо на форме, конечно лучше для этого использовать TPaintBox;

Unit1.pas:

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;

type

  TForm1 = class(TForm)
    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);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormResize(Sender: TObject);
  private
    FStartX, FStartY:Integer;
    FIsButtonDown:boolean;
    FBuffer:TBitMap;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  //ControlStyle:=ControlStyle+[csOpaque];
  //DoubleBuffered:=true;
  FIsButtonDown:=false;
  FBuffer:=TBitmap.Create;
  FBuffer.Height:=Height;
  FBuffer.Width:=Width;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FStartX:=X;
  FStartY:=Y;
  FIsButtonDown:=true;
  BitBlt(FBuffer.Canvas.Handle,0,0,Width,Height,Canvas.Handle,0,0,SRCCOPY);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (FIsButtonDown) then
    begin
    BitBlt(Canvas.Handle,0,0,Width,Height,FBuffer.Canvas.Handle,0,0,SRCCOPY);
    if (ssCtrl in Shift) then Canvas.Rectangle(FStartX, FStartY, X, Y)
      else
        with Canvas do
          begin
          MoveTo(FStartX, FStartY);
          LineTo(X, Y);
          end;
    end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (FIsButtonDown) then
    begin
    FormMouseMove(Sender, Shift, X, Y);
    BitBlt(FBuffer.Canvas.Handle,0,0,Width,Height,Canvas.Handle,0,0,SRCCOPY);
    FIsButtonDown:=false;
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBuffer.Destroy;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  FBuffer.Height:=Height;
  FBuffer.Width:=Width;
end;

end.

Unit1.dfm:

Код:

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 870
  Height = 640
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnMouseDown = FormMouseDown
  OnMouseMove = FormMouseMove
  OnMouseUp = FormMouseUp
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
end

Project1.dpr:

Код:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

[AND_REY]

Вот ещё Canvas.rar с фиксацией.

[Asinkrit]

Сообщение от AND_REY

Вот ещё Вложение 1138 с фиксацией.

Мимо темы....

[melloun]

Спасибо огромное обоим.

[Asinkrit]

Тот же код, с комментариями, специально для melloun...
Во первых определим в форме вспомогательные переменные,
а именно:

Код:

  ...
  private
    FStartX, FStartY:Integer; //координаты в момент события MouseDown
    FIsButtonDown:boolean;   //флаг, определяющий нажата кнопка или нет
    FBuffer:TBitMap;             //Буффер, в котором будем хранить изображение
  public
  ...

При создании формы, определим начальные значения

Код:

  ...
  //ControlStyle:=ControlStyle+[csOpaque]; //если рисовать на TPaintBox, то
    //это отключит его перерисовку, и уберет мерцания..
  //DoubleBuffered:=true;     //иногда помогает избавиться от мерцания
  FIsButtonDown:=false;      //кнопка не нажата
  FBuffer:=TBitmap.Create;  //создаем битмар
  FBuffer.Height:=Height;     //с размерами формы
  FBuffer.Width:=Width;
  ...

При нажатии кнопки мышки:

Код:

  ...
  FStartX:=X;FStartY:=Y;   //запомним координаты
  FIsButtonDown:=true;      //запомним что кнопка была нажата
    // и скопируем в буффер содержимое формы.
  BitBlt(FBuffer.Canvas.Handle,0,0,Width,Height,Canvas.Handle,0,0,SRCCOPY);
  ...

При движении курсора над формой:

Код:

 
  ...
  if (FIsButtonDown) then //проверяем, если была нажата кнопка мыши, то
    begin
      //восстанавливаем изображение на форме из буффера
    BitBlt(Canvas.Handle,0,0,Width,Height,FBuffer.Canvas.Handle,0,0,SRCCOPY);
      //если был нажат Ctrl, то рисуем прямоугольник
    if (ssCtrl in Shift) then Canvas.Rectangle(FStartX, FStartY, X, Y)
      else //иначе линию
        with Canvas do
          begin
          MoveTo(FStartX, FStartY);
          LineTo(X, Y);
          end;
    end;
  ..

При отпускании кнопки мыши:

Код:

  ...
  if (FIsButtonDown) then проверяем, если была ли нажата кнопка мышы, то
    begin
    FormMouseMove(Sender, Shift, X, Y); //вызовем событие MouseMove,
      //для того, что бы перерисовать с последними координатами
    BitBlt(FBuffer.Canvas.Handle,0,0,Width,Height,Canvas.Handle,0,0,SRCCOPY);
    FIsButtonDown:=false; //и запомним, что кнопка мыши отпущена
    end;
  ...

Ну и соответственно, при уничтожении формы, грохаем буффер,
а при изменении размеров формы, изменяем размеры буффера.

На самом деле, это не самая удачная реализация, на скорую руку, этот алгоритм можно еще очень неплохо оптимизировать, хотя для решения твоей задачи, тебе должно хватить.

Если будут вопросы, задавай...

[melloun]

можно еще как распределить по кнопкам мыши левую и правую. А так же процедуру чтоб на экране можно было рисовать только одну фигуру, при рисовании следующей - предыдущая пропадала

[Asinkrit]

Так определяется какая кнопка была нажата:

Код:

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  case Button  of
    mbLeft: ;  //нажата левая кнопка
    mbRight: ; //правая
    mbMiddle: ;//средняя
  end;
end;

Очистка канвы, в данном случае формы

Код:

PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, Form1.Color);

[melloun]

возникает ошибка при очистке формы, вся форма заливается черным

[Asinkrit]

извини напутал), вот так можешь ее очистить

Код:

 
  with Canvas do
    begin
    Brush.Style:=bssolid;
    Brush.Color:=Form1.Color;
    Pen.Style:=psSolid;
    Pen.Color:=Form1.Color;
    Rectangle(ClipRect);
    end;

[melloun]

куда именно поместить

Код:

    Brush.Style:=bssolid;
    Brush.Color:=Form1.Color;
    Pen.Style:=psSolid;
    Pen.Color:=Form1.Color;
    Rectangle(ClipRect);

lmikle: Где теги, я вас спрашиваю!!!

[Asinkrit]

первым действием в FormMouseDown