Показать сообщение отдельно
  #5  
Старый 09.01.2010, 21:40
Asinkrit Asinkrit вне форума
Местный
 
Регистрация: 29.10.2009
Сообщения: 446
Репутация: 271
По умолчанию

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

рисуем прямо на форме, конечно лучше для этого использовать 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.
Ответить с цитированием