Marco Web Center

[an error occurred while processing this directive]

Home: Code Repository: Mastering Delphi 6

Chapter 09 - Project QMouseOne

Project Structure

QMouseOne.dpr
program QMouseOne;

uses
  QForms,
  MouseF in 'MouseF.pas' {MouseForm};

{$R *.res}

begin
  Application.CreateForm(TMouseForm, MouseForm);
  Application.Run;
end.
MouseF.pas
unit MouseF;

interface

uses Qt, Classes, QGraphics,
  QControls, QForms, SysUtils, Types;

type
  TMouseForm = class(TForm)
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormPaint(Sender: TObject);
  private
    fDragging: Boolean;
    fRect: TRect;
  public
    { Public declarations }
  end;

var
  MouseForm: TMouseForm;

implementation

{$R *.xfm}

procedure TMouseForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    fDragging := True;
    Mouse.Capture := Self; // the form captures the mouse
    fRect.Left := X;
    fRect.Top := Y;
    fRect.BottomRight := fRect.TopLeft;
    Canvas.DrawFocusRect (fRect);
  end;
end;

procedure TMouseForm.FormMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  // display the position of the mouse in the caption
  Caption := Format ('Mouse in x=%d, y=%d', [X, Y]);
  if fDragging then
  begin
    // remove and redraw the dragging rectangle
    Canvas.DrawFocusRect (fRect);
    fRect.Right := X;
    fRect.Bottom := Y;
    Canvas.DrawFocusRect (fRect);
  end
  else
    if ssShift in Shift then
    begin
      // mark points in yellow
      Canvas.Pen.Color := clYellow;
      Canvas.DrawPoint (X, Y);
    end;
end;

procedure TMouseForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if fDragging then
  begin
    Mouse.Capture := nil; // release the mouse capture
    fDragging := False;
    Invalidate;
  end;
end;

procedure TMouseForm.FormPaint(Sender: TObject);
begin
  Canvas.Pen.Color := clBlue;
  Canvas.Rectangle (fRect.Left, fRect.Top,
    fRect.Right, fRect.Bottom);
end;

end.
MouseF.xfm
object MouseForm: TMouseForm
  Left = 223
  Top = 108
  Width = 435
  Height = 300
  Caption = 'Mouse'
  Color = clButton
  Font.Color = clText
  Font.Height = 13
  Font.Name = 'System'
  Font.Pitch = fpVariable
  Font.Style = []
  Font.Weight = 40
  ParentFont = False
  OnMouseDown = FormMouseDown
  OnMouseMove = FormMouseMove
  OnMouseUp = FormMouseUp
  OnPaint = FormPaint
  PixelsPerInch = 96
  TextHeight = 16
  TextWidth = 8
end