sizercontrol.pas

Delphi 拖放控件

unit sizecontrol;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TSizerControl = class(TCustomControl)
  private
    FControl: TControl;
    FRectList: array[1..8] of TRect;
    FPosList: array[1..8] of Integer;
    procedure WmNcHitTest(var Msg: TWmNcHitTest); message wm_NcHitTest;
    procedure WmSize(var Msg: TWmSize); message wm_Size;
    procedure WmLButtonDown(var Msg: TWmLButtonDown); message wm_LButtonDown;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WmMove(var Msg: TWmMove); message Wm_Move;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    // procedure Createhandle; override;
     { Private declarations }
  protected
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    procedure CreateParams(var Params: TCreateParams); override;

    procedure Paint; override;

    procedure SetControl(AControl: TControl);

    { Public declarations }
  published
    { Published declarations }
  end;
const
  sc_DragMove: Longint = $F012;

implementation

constructor TSizerControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FControl := self;
end;

procedure TSizerControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);                          
  Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
{
procedure TSizerControl.Createhandle;
begin
  inherited Createhandle;
  SetFocus;
end;
}

procedure TSizerControl.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
  I: Integer;
begin
  Pt := Point(Msg.XPos, Msg.YPos);
  Pt := ScreenToClient(Pt);
  Msg.Result := 0;
  //检测鼠标位置并改变状态
  for I := 1 to 8 do
    if PtInRect(FRectList[I], Pt) then Msg.Result := FPosList[I];
  if Msg.Result = 0 then inherited;
  Paint;                                                    //.... 这个不可少
end;

procedure TSizerControl.WmSize(var Msg: TWmSize);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect(R, -2, -2);
  FControl.BoundsRect := R;
  //计算8个黑方框
  FRectList[1] := Rect(0, 0, 5, 5);
  FRectList[2] := Rect(Width div 2 - 3, 0, Width div 2 + 2, 5);
  FRectList[3] := Rect(Width - 5, 0, Width, 5);
  FRectList[4] := Rect(Width - 5, height div 2 - 3, Width, Height div 2 + 2);
  FRectList[5] := Rect(Width - 5, Height - 5, Width, Height);
  FRectList[6] := Rect(Width div 2 - 3, Height - 5, Width div 2 + 2, Height);
  FRectList[7] := Rect(0, Height - 5, 5, Height);
  FRectList[8] := Rect(0, Height div 2 - 3, 5, Height div 2 + 2);
end;

procedure TSizerControl.WmLButtonDown(var Msg: TWmLButtonDown);
begin
  //执行拖动命令
  Perform(Wm_SysCommand, sc_DragMove, 0);
  Paint;
 // FControl.Perform(Msg.Msg, Msg.XPos, Msg.YPos);
end;

procedure TSizerControl.WMLButtonUp(var Message: TWMLButtonUp);
begin
//  FControl.Perform(Message.Msg, Message.XPos, Message.YPos);
end;

procedure TSizerControl.WmMove(var Msg: TWmMove);
var
  R: TRect;
begin
  Visible := False;                                         //... 这样解决重绘、覆盖问题
  R := BoundsRect;
  InflateRect(R, -2, -2);
  FControl.Invalidate;
  FControl.BoundsRect := R;
  Visible := True;

end;

procedure TSizerControl.Paint;
var
  I: Integer;
begin
  Canvas.Brush.Color := clRed;                              //   clBlack
  for I := 1 to 8 do with FRectList[I] do Canvas.Rectangle(Left, Top, Right, Bottom);
end;

procedure TSizerControl.SetControl(AControl: TControl);
var
  R: TRect;
begin
  FControl := AControl;
  R := FControl.BoundsRect;
  InflateRect(R, 2, 2);
  BoundsRect := R;
  Parent := FControl.Parent;
  FPosList[1] := htTopLeft;
  FPosList[2] := htTop;
  FPosList[3] := htTopRight;
  FPosList[4] := htRight;
  FPosList[5] := htBottomRight;
  FPosList[6] := htBottom;
  FPosList[7] := htBottomLeft;
  FPosList[8] := htLeft;
  //... 由下面的消息替换...  WMEraseBkgnd
// FControl.Update;

end;

procedure TSizerControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 0
end;

end.