运行期可以变动大小和尺寸的自定义控件、

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.