unit CcDrag;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, Forms;
type
TMousePosition = (mpNone, mpRightBottom, mpRight, mpBottom);
TCcDrag = class(TGraphicControl)
private
{ Private Declarations }
FMouseDown: Boolean;
FDownPt: TPoint;
FMousePos: TMousePosition;
FOldWidth: Integer;
FOldHeight: Integer;
FLtdControl: TControl;
FAssignControl: Boolean;
FBoundsRect: TRect;
FFixSize: Boolean;
FFixHeight: Integer;
FFixWidth: Integer;
procedure SetLtdControl(const Value: TControl);
procedure AdjustControlBounds(const ABoundsRec: TRect);
procedure SetControlBounds(const ABoundsRect: TRect);
procedure SetFixSize(const Value: Boolean);
protected
{ Protected Declarations }
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure Paint; override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
// Big Z Add This Procedure
// 避免在限制边缘拖动时的闪烁，使其表现更好！
procedure AdjustPosition(const OffsetX, OffsetY: Integer); virtual;
public
{ Public Declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published Declarations }
property LtdControl: TControl read FLtdControl write SetLtdControl;
// Big Z Add This 2000.07.21 10:20
// 增加一个属性，是否可以改变大小
property FixSize: Boolean read FFixSize write SetFixSize;
property Width default 90;
property Height default 120;
property Align;
property Anchors;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
{$IFDEF VER130}
property OnContextPopup;
{$ENDIF}
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
implementation
const
OFFSET = 5;
procedure TCcDrag.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
{Method implementation code}
inherited MouseDown(Button, Shift, X, Y);
if Button = mbLeft then
begin
FMouseDown := True;
FDownPt := Point(X, Y);
FOldWidth := Width;
FOldHeight := Height;
if Assigned(FLtdControl) then
FBoundsRect := FLtdControl.BoundsRect;
if FMousePos = mpNone then
Screen.Cursor := crDrag;
end
end; {MouseDown}
procedure TCcDrag.MouseMove(Shift: TShiftState; X, Y: Integer);
var
OffsetX, OffsetY: Integer;
begin
{Method implementation code}
inherited MouseMove(Shift, X, Y);
if FMouseDown then
begin
OffsetX := X - FDownPt.x;
OffsetY := Y - FDownPt.y;
case FMousePos of
mpNone:
begin
{Left := OffsetX + Left;
Top := OffsetY + Top;
if FAssignControl then
AdjustControlBounds(FBoundsRect)}
// Big Z Modify Here 2000.07.21 11:18
AdjustPosition(OffsetX, OffsetY);
end;
mpRight:
begin
if FOldWidth + OffsetX > 0 then
Width := FOldWidth + OffsetX;
if FAssignControl then
SetControlBounds(FBoundsRect)
end;
mpBottom:
begin
if FOldHeight + OffsetY > 0 then
Height := FOldHeight + OffsetY;
if FAssignControl then
SetControlBounds(FBoundsRect)
end;
mpRightBottom:
begin
if FOldWidth + OffsetX > 0 then
Width := FOldWidth + OffsetX;
if FOldHeight + OffsetY > 0 then
Height := FOldHeight + OffsetY;
if FAssignControl then
SetControlBounds(FBoundsRect)
end
end;
end
else
begin
if (X >= Width - OFFSET) and (Y >= Height - OFFSET) then
begin
Cursor := crSizeNWSE;
FMousePos := mpRightBottom;
end
else if X >= Width - OFFSET then
begin
Cursor := crSizeWE;
FMousePos := mpRight
end
else if Y >= Height - OFFSET then
begin
Cursor := crSizeNS;
FMousePos := mpBottom
end
else
begin
Cursor := crDefault;
FMousePos := mpNone
end;
// Big Z Add This 2000.07.21 10:26
// 如果设定了 FixSize 属性，则尺寸的固定的值
if FFixSize then
begin
Cursor := crDefault;
FMousePos := mpNone
end
end
end; {MouseMove}
procedure TCcDrag.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
begin
{Method implementation code}
inherited MouseUp(Button, Shift, X, Y);
FMouseDown := False;
Screen.Cursor := crDefault
end; {MouseUp}
constructor TCcDrag.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{Add any other initialization code here}
Width := 90;
Height := 120;
end; {Create}
procedure TCcDrag.Paint;
procedure PaintDot(X, Y: Integer);
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clBlack;
Canvas.Pen.Style := psSolid;
Canvas.Pen.Color := clBlack;
Canvas.Pen.Mode := pmCopy;
Canvas.Rectangle(X - 2, Y - 2, X + 2, Y + 2);
end;
begin
inherited;
Canvas.Pen.Style := psDot;
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clRed;
Canvas.Pen.Mode := pmNot;
Canvas.Rectangle(0, 0, Width, Height);
// Big Z Add This 2000.07.21 11:32
if not FFixSize then
begin
PaintDot(Width, Height shr 1);
PaintDot(Width shr 1, Height);
PaintDot(Width, Height)
end;
end;
procedure TCcDrag.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opReMove) and (AComponent = FLtdControl) then
FLtdControl := nil
end;
procedure TCcDrag.SetLtdControl(const Value: TControl);
begin
if FLtdControl <> Value then
begin
FLtdControl := Value;
FAssignControl := Assigned(Value);
if FAssignControl then
begin
FBoundsRect := Value.BoundsRect;
SetControlBounds(FBoundsRect);
end
end
end;
procedure TCcDrag.SetControlBounds(const ABoundsRect: TRect);
begin
if ABoundsRect.Left > Left then
Left := ABoundsRect.Left;
if ABoundsRect.Top > Top then
Top := ABoundsRect.Top;
if ABoundsRect.Right < (Left + Width) then
Width := ABoundsRect.Right - Left;
if ABoundsRect.Bottom < (Top + Height) then
Height := ABoundsRect.Bottom - Top
end;
procedure TCcDrag.AdjustControlBounds(const ABoundsRec: TRect);
begin
if ABoundsRec.Left > BoundsRect.Left then
Left := ABoundsRec.Left;
if ABoundsRec.Top > BoundsRect.Top then
Top := ABoundsRec.Top;
if ABoundsRec.Right < BoundsRect.Right then
Left := ABoundsRec.Right - Width;
if ABoundsRec.Bottom < BoundsRect.Bottom then
Top := ABoundsRec.Bottom - Height
end;
// Big Z Add This 2000.07.21 10:26
// 如果设定了 FixSize 属性，则尺寸的固定的值
// ----------------------------------------------------------------------------
procedure TCcDrag.SetFixSize(const Value: Boolean);
begin
if FFixSize <> Value then
begin
FFixSize := Value;
end;
end;
// Big Z Add This Procedure
// 避免在限制边缘拖动时的闪烁，使其表现更好！
procedure TCcDrag.AdjustPosition(const OffsetX, OffsetY: Integer);
begin
if not FAssignControl then
begin
Left := Left + OffsetX;
Top := Top + OffsetY;
Exit;
end;
if Left + OffsetX < FBoundsRect.Left then
Left := FBoundsRect.Left
else if Left + OffsetX + Width > FBoundsRect.Right then
Left := FBoundsRect.Right - Width
else
Left := Left + OffsetX;
if Top + OffsetY < FBoundsRect.Top then
Top := FBoundsRect.Top
else if Top + OffsetY + Height > FBoundsRect.Bottom then
Top := FBoundsRect.Bottom - Height
else
Top := Top + OffsetY;
end;
end.
