Mega Code Archive
Selectionbox component
<![CDATA[
Title: Selectionbox component
Question: How to make a selectionbox
Answer:
{------------------------------------------------------------------------
Written for:
DELPHI 3.0 or higher
This selection box can be used or modified freely.
Usage
-----
Place the selection box exactly over an TImage
component. In this way you are able to select a
certain region (rectangle) of the image and copy
it, and paste it in the same image or as a new
image.
New Properties
--------------
* LineStyle
lsDash (same as Delphi psDash)
lsSingle (same as Delphi psSolid)
lsDouble (two psSolid lines)
lsDot (same as Delphi psDot)
The selection lines are drawn in Delphi's pmXor mode.
This is done because I didn't find an other fast way to
clear (make transparent) the canvas, while changing the
size of the selection box.
You can draw the selectionbox in a certain color but
then you have to remove the previous box (with refresh)
every time you change the size of the selection box.
This will give a lot of flickering.
* X1 -- Top of selectionbox
* X2 -- Bottom of selectionbox
* Y1 -- Left of selectionbox
* Y2 -- Right of selectionbox
Coordinates of the box on the TImage. (Read and write.)
* Selmode
smNone -- once the selectionbox is drawn, it can not
be resized or moved
smMove -- you are able to move the complete selectionbox
smDrag -- you are able to resize the selctionbox
smBoth -- smMove + smDrag
* Cadre
This is the sensitivity width of the cadre. If you place
the mouse over the border of the selection box, the mouse
will change in crSizeNS or crSizeWE. When you make Cadre = 1
only when the mouse is 1 pixel away from the border of the
selectionbox, it will change in crSizeNS or crSizeWE.
Events
------
* SelectionReady
A selection box is ready and visible.
* NothingSelected
A selection box is not visible, there is nothing selected.
* SelectionChanges
The selectionbox is resized or moved
You can use this event to display the selection size during
a change of selection
Procedures/Functons
-------------------
* Reset
A selection box is not visible. All necessary variables are
reset.
* SelectionboxRefresh
The selection box is redrawn.
Known bugs
----------
1. When moving the selectionbox it is possible to move
a part of the selection box outside the border of the
paintbox.
2. When drawing a selectionbox it is possible to draw
the selectionbox outside the paintbox. After entering
the paintbox again, you will notice that the selectionbox
is still "sticked to the cursor" even if you have released
the mouse button (outside the paintbox).
Both bugs are a bit inconveniant but not harmfull.
Writer name: Maarten de Haan
Email: M.deHaan@inn.nl
------------------------------------------------------------------------}
Unit SelectionBox;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
{$R MYCUR1.RES}
{No crSize was found in Delphi 3...}
Const
crMove = 1; // move cursor: with four arrows N, S, E and W
crSelect = 2; // select cursor: cross like a plus sign with a box to
// indicate a selectionbox
Type
TSelectedState = (ssSelected,ssUnSelected); // internal
TMouseState = (msMouseDown,msMouseUp); // interal}
TLineStyle = (lsDash,lsSingle,lsDot,lsDouble); // external
TSelMode = (smNone,smMove,smDrag,smBoth); // external
TCurrentMode = (cmNone,cmMoving,cmDragging); // internal
TDragLine =(dlNone,dlLeft,dlTop,dlRight,dlBottom); // internal
TSelectionBox = class(TPaintBox)
Private
{ Private declarations }
fX1,fX2,fY1,fY2 : Integer; // internal coordinates
ffX1,ffX2,ffY1,ffY2 : Integer; // external coordinates
// always: ffX2 ffX1 and ffY2 ffY1
fNew : Boolean; // internal variable
fRect : TRect; // rect var (not used)
fCadre : Integer; // sensitivity cadre width for changing
// the mouse
fSelectedState : TSelectedState;// state of selection
fMouseState : TMouseState; // mouse state (up or down)
fLineStyle : TLineStyle; // line style (lsDash,lsSingle,lsDot,lsDouble)
fSelMode : TSelMode; // mode (smNone,smMove,smDrag,smBoth)
fCurrentMode : TCurrentMode; // current mode (cmNone,cmMoving,cmDragging)
fYOld,fXOld : Integer; // old values of mouse position
fColor : TColor; // remove from object inspector
fDragMode : TDragMode; // remove from object inspector
fDragLine : TDragLine; // which line to drag (dlNone,dlLeft,dlTop,dlRight,dlBottom)
fSelectionReady : TNotifyEvent; // notify when there is a selection
fNothingSelected : TNotifyEvent; // notify when there is no selection
fSelectionChanges : TNotifyEvent; // notify when the selectionbox changes
Procedure MouseDownMessage(var Msg : TMessage);
message WM_LBUTTONDOWN; // left mouse button down
Procedure MouseMoveMessage(var Msg : TMessage);
message WM_MOUSEMOVE; // mouse move
Procedure MouseUpMessage(var Msg : TMessage);
message WM_LBUTTONUP; // left mouse button up
Procedure fSetCadre(Value : Integer); // cadre width
Procedure fCheckCoordinates; // make ffX2 ffX1 and ffY2 ffY1
Procedure fSetX1(Value : Integer); // Set X1
Procedure fSetY1(Value : Integer); // Set Y1
Procedure fSetX2(Value : Integer); // Set X2
Procedure fSetY2(Value : Integer); // Set Y2
Protected
{ Protected declarations }
Constructor Create(AOwner : TComponent); override;
Procedure DrawSelectionbox; // drawing of the selection box
Procedure SelectionReady; dynamic; // add new event
Procedure NothingSelected; dynamic; // add new event
Procedure SelectionChanges; dynamic; // add new event
Public
Procedure Reset; // Reset the selection box
Procedure SelectionBoxRefresh; // Redraw the selection box
{ Public declarations }
Published
{ Published declarations }
Property LineStyle : TLineStyle
read fLineStyle write fLineStyle; // line style
Property X1 : Integer
read ffX1 write fSetX1; // X1
Property Y1 : Integer
read ffY1 write fSetY1; // Y1
Property X2 : Integer
read ffX2 write fSetX2; // X2
Property Y2 : Integer
read ffY2 write fSetY2; // Y2
Property SelMode : TSelMode
read fSelMode write fSelMode; // mode
Property Cadre : Integer
read fCadre write fSetCadre; // cadre width
Property OnSelectionReady : TNotifyEvent
read fSelectionReady write fSelectionReady; // event
Property OnNothingSelected : TNotifyEvent
read fNothingSelected write fNothingSelected; // event
Property OnSelectionChanges : TNotifyEvent
read fSelectionChanges write fSelectionChanges; // event
Property Color : TColor // remove from object inspector
read fColor;
Property DragMode : TDragMode // remove from object inspector
read fDragMode;
End;
Procedure Register; // hello
Implementation
{----------------------------------------------------------------------}
Procedure TSelectionBox.SelectionBoxRefresh;
Begin
Refresh; {clear}
fCheckCoordinates;
DrawSelectionBox; {redraw with old coordinates}
fNew := True;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fSetX1(Value : Integer);
Begin
If (Value = 0) then
Begin
Refresh; {clear}
fX1 := Value;
DrawSelectionBox;
fNew := True;
End;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fSetX2(Value : Integer);
Begin
If (Value = 0) then
Begin
Refresh; {clear}
fX2 := Value;
DrawSelectionBox;
fNew := True;
End;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fSetY1(Value : Integer);
Begin
If (Value = 0) then
Begin
Refresh; {clear}
fY1 := Value;
DrawSelectionBox;
fNew := True;
End;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fSetY2(Value : Integer);
Begin
If Value = 0 then
Begin
Refresh; {clear}
fY2 := Value;
DrawSelectionBox;
fNew := True;
End;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fCheckCoordinates;
Begin
ffX1 := fX1;
ffX2 := fX2;
ffY1 := fY1;
ffY2 := fY2;
// Change coordinates for the outside, if X1 X2
If fX1 fX2 then
Begin
ffX1 := fX2;
ffX2 := fX1;
End; // of if
// Change coordinates for the outside, if Y1 Y2
If fY1 fY2 then
Begin
ffY1 := fY2;
ffY2 := fY1;
End; // of if
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.SelectionChanges;
Begin
if Assigned(fSelectionChanges) then
fSelectionChanges(Self);
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.SelectionReady;
Begin
if Assigned(fSelectionReady) then
fSelectionReady(Self);
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.NothingSelected;
Begin
if Assigned(fNothingSelected) then
fNothingSelected(Self);
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.Reset;
Begin
{Reset the selection box}
Refresh; {clear}
{Initialize}
fX1 := 0;
fX2 := 0;
fY1 := 0;
fY2 := 0;
ffX1 := 0;
ffX2 := 0;
ffY1 := 0;
ffY2 := 0;
If fSelectedState = ssSelected then
Begin
fSelectedState := ssUnSelected;
End;
fNew := True;
NothingSelected;
End;
{----------------------------------------------------------------------}
Procedure TSelectionBox.fSetCadre(Value : Integer);
Begin
If (Value 0) and (Value Begin
fCadre := Value;
End; // of if
End; // of procedure
{----------------------------------------------------------------------}
Procedure TSelectionBox.MouseDownMessage(var Msg : TMessage);
Var
X,Y : Integer;
Begin
X := Msg.lParamLo;
Y := Msg.lParamHi;
fMouseState := msMouseDown; // mouse is down
SelectionChanges;
If (fSelMode = smNone) then
Begin
DrawSelectionBox;
fX1 := X;
fY1 := Y;
fCurrentMode := cmNone;
fNew := True;
End // of if
else
Begin // fSelMode smNone
If (fCurrentMode = cmMoving) or
(fCurrentMode = cmDragging) then
Begin
fXOld := X;
fYOld := Y;
End; // of if
If (fCurrentMode = cmNone) then
Begin
DrawSelectionBox;
fX1 := X;
fY1 := Y;
fNew := True;
End; // of if
End; // of else
End; // of proc
{----------------------------------------------------------------------}
Procedure TSelectionBox.MouseMoveMessage(var Msg : TMessage);
Var
X,Y : Integer;
DX,DY : Integer;
Bo1,Bo2 : Boolean;
Begin
X := Msg.lParamLo; // get mouse x pos
Y := Msg.lParamHi; // get mouse y pos
fCheckCoordinates;
// Init Bo1 and Bo2
Bo1 := False;
Bo2 := False;
//------------------------------MOUSE IS UP----------
If fMouseState = msMouseUp then
If (fX1 fX2) and (fY1 fY2) then
SelectionReady;
{Dragging, mouse is up}
If (fMouseState = msMouseUp) then
If ((fSelMode = smDrag) or (fSelMode = smBoth)) then
Begin
If (Abs(X - fX1) If (Y = ffY1 + fCadre) and (Y Begin
Cursor := crSizeWE;
Bo1 := True;
fDragLine := dlLeft;
fCurrentMode := cmDragging;
End; // of if
If (Abs(X - fX2) If (Y = ffY1 + fCadre) and (Y Begin
Cursor := crSizeWE;
Bo1 := True;
fDragLine := dlRight;
fCurrentMode := cmDragging;
End; // of if
If (Abs(Y - fY1) If (X = ffX1 + fCadre) and (X Begin
Cursor := crSizeNS;
Bo1 := True;
fDragLine := dlTop;
fCurrentMode := cmDragging;
End; // of if
If (Abs(Y - fY2) If (X = ffX1 + fCadre) and (X Begin
Cursor := crSizeNS;
Bo1 := True;
fDragLine := dlBottom;
fCurrentMode := cmDragging;
End; // of if
If Bo1 = False then
Begin
fDragLine := dlNone;
fCurrentMode := cmNone;
End; // of if
End; // of if
// Moving, mouse is up
If (fMouseState = msMouseUp) then
If (fNew = True) and ((fSelMode = smMove) or (fSelMode = smBoth)) then
Begin
If (X = ffX1 + fCadre) and (X (Y = ffY1 + fCadre) and (Y Begin
Cursor := crMove;
fCurrentMode := cmMoving;
Bo2 := True;
End; // of if
End; // of if
// Change cursor shape when dragging or moving
If Bo1 = True then
fCurrentMode := cmDragging;
If Bo2 = True then
fCurrentMode := cmMoving;
//------------------------------MOUSE IS DOWN--------
// Moving the selection area, when mouse is down
If (fMouseState = msMouseDown) then
Begin
If ((fSelMode = smMove) or (fSelMode = smBoth)) then
If (fCurrentMode = cmMoving) then
Begin
fCurrentMode := cmMoving;
DrawSelectionBox;
DX := fXOld - X;
DY := fYOld - Y;
fX1 := fX1 - DX;
fY1 := fY1 - DY;
fX2 := fX2 - DX;
fY2 := fY2 - DY;
DrawSelectionBox;
fXOld := X;
fYOld := Y;
Cursor := crMove;
Bo1 := True;
End; // of if
End;
// No moving and no dragging, when the mouse is down
If (fMouseState = msMouseDown) then
Begin
If (fCurrentMode = cmNone) then
Begin
If fNew = False then
DrawSelectionBox; // clear previous box while moving the mouse
fX2 := Msg.lParamLo; // get mouse x2
fY2 := Msg.lParamHi; // get mouse y2
DrawSelectionBox; // draw new selection box
Bo1 := False;
Bo2 := False;
fNew := False;
End; // of if
End;
// Dragging the selection area, when mouse is down
If (fMouseState = msMouseDown) then
Begin
If ((fSelMode = smDrag) or (fSelMode = smBoth)) then
If (fCurrentMode = cmDragging) then
If fDragLine dlNone then
Begin
fCurrentMode := cmDragging;
DrawSelectionBox;
DX := fXOld - X;
DY := fYOld - Y;
If fDragLine = dlLeft then
Begin
fX1 := fX1 - DX;
Cursor := crSizeWE;
End; // of if
If fDragLine = dlRight then
Begin
fX2 := fX2 - DX;
Cursor := crSizeWE;
End; // of if
If fDragLine = dlTop then
Begin
fY1 := fY1 - DY;
Cursor := crSizeNS;
End; // of if
If fDragLine = dlBottom then
Begin
fY2 := fY2 - DY;
Cursor := crSizeNS;
End; // of if
DrawSelectionbox;
fXOld := X;
fYOld := Y;
Bo2 := True;
End; // of if
End;
If (Bo1 = False) and (Bo2 = False) then
Cursor := crSelect;
End; // of procedure
{----------------------------------------------------------------------}
Procedure TSelectionBox.MouseUpMessage(var Msg : TMessage);
Var
X,Y : Integer;
Begin
fMouseState := msMouseUp; // end of drawing selection box
fCurrentMode := cmNone; // clear current mode
fDragLine := dlNone; // no line to drag
Cursor := crSelect; // select cursor
fNew := True;
X := Msg.lParamLo;
Y := Msg.lParamHi;
If (X = fX1) and (Y = fY1) then
Begin // mouse did not move, just clicked, so clear the selection box
fX2 := fX1;
fY2 := fY1;
If fSelectedState = ssSelected then
Begin
fSelectedState := ssUnSelected;
NothingSelected;
End;
End; // of if
End; // of procedure
{----------------------------------------------------------------------}
Procedure TSelectionBox.DrawSelectionbox;
Begin
SelectionChanges;
fCheckCoordinates;
Canvas.Pen.Color := clWhite; // must be white
Canvas.Pen.Mode := pmXor; // xor mask
Canvas.Pen.Style := psSolid; // default
Case fLineStyle of
lsSingle,lsDouble : Canvas.Pen.Style := psSolid; // solid
lsDot : Canvas.Pen.Style := psDot; // dot
lsDash : Canvas.Pen.Style := psDash; // dash
End; // of Case
If (fX1 fX2) or (fY1 fY2) then
Begin
Canvas.MoveTo(fX1,fY1); // move to x1,y1
Canvas.LineTo(fX2,fY1); // draw from x1,y1 to x2,y1
Canvas.LineTo(fX2,fY2); // draw from x2,y1 to x2,y2
Canvas.LineTo(fX1,fY2); // draw from x2,y2 to x1,y2
Canvas.LineTo(fX1,fY1); // draw from x1,y2 to x1,y1
{double lines, thicker}
If fLineStyle = lsDouble then
Begin
Canvas.MoveTo(fX1 - 1,fY1 - 1);
// draw from x1 - 1,y1 - 1 to x2 + 1,y1 - 1
Canvas.LineTo(fX2 + 1,fY1 - 1);
// draw from x2 + 1,y1 - 1 to x2 + 1,y2 + 1
Canvas.LineTo(fX2 + 1,fY2 + 1);
// draw from x2 + 1,y2 + 1 to x1 - 1,y2 + 1
Canvas.LineTo(fX1 - 1,fY2 + 1);
// draw from x1 - 1,y2 + 1 to x1 - 1,y1 - 1
Canvas.LineTo(fX1 - 1,fY1 - 1);
End;
End;
If (fX1 fX2) and (fY1 fY2) then
If fSelectedState = ssUnSelected then
Begin
fSelectedState := ssSelected;
End;
If (fX1 = fX2) or (fY1 = fY2) then
If fSelectedState = ssSelected then
Begin
fSelectedState := ssUnSelected;
End;
End; // of procedure
{----------------------------------------------------------------------}
Constructor TSelectionbox.Create(AOwner : TComponent);
Begin
inherited Create(AOwner); // create component
// initialize fx,fy
fX1 := 0;
fY1 := 0;
fX2 := 0;
fY2 := 0;
// initialize ffx,ffy
ffX1 := 0;
ffX2 := 0;
ffY1 := 0;
ffY2 := 0;
// initialize variables
fNew := True;
fRect := Rect(fX1,fY1,fX2,fY2); // not used
fMouseState := msMouseUp; // mouse is up
fLineStyle := lsSingle; // linestyle solid/single
Canvas.Pen.Style := psSolid; // linestyle solid/single
fSelMode := smNone; // no moving or dragging
fCurrentMode := cmNone; // no current mode yet
fCadre := 3; // set cadre width
Inherited Color := clBtnFace; // remove from obj insp
Inherited Dragmode := dmManual; // remove from obj insp
Screen.Cursors[crMove] := LoadCursor(HInstance,'MOVE');
//A cursor with cross NESW
{!! The cursor type crSize was not found in Delphi3 !! Although it should
be there !!}
Screen.Cursors[crSelect] := LoadCursor(HInstance,'SELECT');
//A cursor like a plus sign and a (small) rectangle to indicate a
//selectionbox
fSelectedState := ssUnSelected;
{Add new cursor}
End; // of procedure
{----------------------------------------------------------------------}
Procedure Register;
Begin
RegisterComponents('Samples', [TSelectionBox]);
End; // of procedure register
{----------------------------------------------------------------------}
End. // of unit
{======================================================================}
]]>