[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 с фиксацией.

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