ctrldes.pas

类似Delphi Ide的对象查看器 可以在RUNTIME时使用

unit CtrlDes;

interface

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

type

  TMouseZone = (mzNone,mzFrame,mzLeftTop,mzCenterTop,mzRightTop,mzLeftCenter,mzRightCenter,mzLeftBottom,mzCenterBottom,mzRightBottom);
  THintMode = (hmMove,hmSize);
  TControlEvent = procedure(Sender: TObject; TheControl: TControl) of object;
  TControlAllowEvent = procedure(Sender: TObject; TheControl: TControl; var Allow: Boolean) of object;

  TCustomControlDesigner = class;

  TControlDesignerFrame = class(TCustomControl)
  private
    { Private declarations }
    FRegion: HRGN;
    FDragRect: TRect;
    FDragPoint: TPoint;
    FDragZone: TMouseZone;
    FHintWindow: THintWindow;
    FControl: TControl;
    FThickness: Integer;
    FDirectDrag: Boolean;
    FMinSize: Integer;
    FShowMoveSizeHint: Boolean;
    FBorderColor: TColor;
    FFrameColor: TColor;
    FGrabColor: TColor;
    FEnableKeys: Boolean;
    FOnAllowSelectControl: TControlAllowEvent;
    FOnSelectControl: TControlEvent;
    FOnAllowDragControl: TControlAllowEvent;
    FOnDragControl: TControlEvent;
    FOnDblClick: TNotifyEvent;
    procedure UpdateShape;
    function MouseZone(X,Y: Integer): TMouseZone;
    procedure DrawDragRect;
    procedure ShowDragHint(AHint: string);
    procedure HideDragHint;
    function GetDesigner: TCustomControlDesigner;
    procedure SetControl(const Value: TControl);
    procedure SetThickness(const Value: Integer);
    procedure SetBorderColor(const Value: TColor);
    procedure SetFrameColor(const Value: TColor);
    procedure SetGrabColor(const Value: TColor);
    procedure SetEnableKeys(const Value: Boolean);
  protected
    { Protected declarations }
    procedure CreateHandle; override;
    procedure Paint; override;
    procedure WndProc(var Message: TMessage); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdatePosition;
    property Designer: TCustomControlDesigner read GetDesigner;
    property Control: TControl read FControl write SetControl;
    property Thickness: Integer read FThickness write SetThickness;
    property DirectDrag: Boolean read FDirectDrag write FDirectDrag;
    property MinSize: Integer read FMinSize write FMinSize;
    property ShowMoveSizeHint: Boolean read FShowMoveSizeHint write FShowMoveSizeHint;
    property BorderColor: TColor read FBorderColor write SetBorderColor;
    property FrameColor: TColor read FFrameColor write SetFrameColor;
    property GrabColor: TColor read FGrabColor write SetGrabColor;
    property EnableKeys: Boolean read FEnableKeys write SetEnableKeys;
    property OnAllowSelectControl: TControlAllowEvent read FOnAllowSelectControl write FOnAllowSelectControl;
    property OnSelectControl: TControlEvent read FOnSelectControl write FOnSelectControl;
    property OnAllowDragControl: TControlAllowEvent read FOnAllowDragControl write FOnAllowDragControl;
    property OnDragControl: TControlEvent read FOnDragControl write FOnDragControl;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
  end;

  TCustomControlDesigner = class(TComponent)
  private
    { Private declarations }
    FFrame: TControlDesignerFrame;
    FActive: Boolean;
    procedure SetActive(const Value: Boolean);
    function GetControl: TControl;
    procedure SetControl(const Value: TControl);
    function GetThickness: Integer;
    procedure SetThickness(const Value: Integer);
    function GetDirectDrag: Boolean;
    procedure SetDirectDrag(const Value: Boolean);
    function GetMinSize: Integer;
    procedure SetMinSize(const Value: Integer);
    function GetShowMoveSizeHint: Boolean;
    procedure SetShowMoveSizeHint(const Value: Boolean);
    function GetBorderColor: TColor;
    procedure SetBorderColor(const Value: TColor);
    function GetFrameColor: TColor;
    procedure SetFrameColor(const Value: TColor);
    function GetGrabColor: TColor;
    procedure SetGrabColor(const Value: TColor);
    function GetEnableKeys: Boolean;
    procedure SetEnableKeys(const Value: Boolean);
    function GetOnAllowSelectControl: TControlAllowEvent;
    procedure SetOnAllowSelectControl(const Value: TControlAllowEvent);
    function GetOnSelectControl: TControlEvent;
    procedure SetOnSelectControl(const Value: TControlEvent);
    function GetOnAllowDragControl: TControlAllowEvent;
    procedure SetOnAllowDragControl(const Value: TControlAllowEvent);
    function GetOnDragControl: TControlEvent;
    procedure SetOnDragControl(const Value: TControlEvent);
    function GetOnDblClick: TNotifyEvent;
    procedure SetOnDblClick(const Value: TNotifyEvent);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    procedure Update; virtual;
    property Active: Boolean read FActive write SetActive;
    property Control: TControl read GetControl write SetControl;
    property Thickness: Integer read GetThickness write SetThickness;
    property DirectDrag: Boolean read GetDirectDrag write SetDirectDrag;
    property MinSize: Integer read GetMinSize write SetMinSize;
    property ShowMoveSizeHint: Boolean read GetShowMoveSizeHint write SetShowMoveSizeHint;
    property BorderColor: TColor read GetBorderColor write SetBorderColor;
    property FrameColor: TColor read GetFrameColor write SetFrameColor;
    property GrabColor: TColor read GetGrabColor write SetGrabColor;
    property EnableKeys: Boolean read GetEnableKeys write SetEnableKeys;
    property OnAllowSelectControl: TControlAllowEvent read GetOnAllowSelectControl write SetOnAllowSelectControl;
    property OnSelectControl: TControlEvent read GetOnSelectControl write SetOnSelectControl;
    property OnAllowDragControl: TControlAllowEvent read GetOnAllowDragControl write SetOnAllowDragControl;
    property OnDragControl: TControlEvent read GetOnDragControl write SetOnDragControl;
    property OnDblClick: TNotifyEvent read GetOnDblClick write SetOnDblClick;
  end;

  TControlDesigner = class(TCustomControlDesigner)
  published
    { Published declarations }
    property Active;
    property Control;
    property Thickness;
    property DirectDrag;
    property MinSize;
    property ShowMoveSizeHint;
    property BorderColor;
    property FrameColor;
    property GrabColor;
    property EnableKeys;
    property OnAllowSelectControl;
    property OnSelectControl;
    property OnAllowDragControl;
    property OnDragControl;
    property OnDblClick;
  end;

{procedure Register;}

implementation

procedure TControlDesignerFrame.UpdateShape;
var
  R: TRect;
  RGN: HRGN;
begin
  if FRegion<>0 then DeleteObject(FRegion);
  R:=Rect(0,0,Width,Height);
  with R do FRegion:=CreateRectRgn(Left,Top,Right,Bottom);
  InflateRect(R,-FThickness,-FThickness);
  with R do RGN:=CreateRectRgn(Left,Top,Right,Bottom);
  try
    CombineRgn(FRegion,FRegion,RGN,RGN_DIFF);
  finally
    DeleteObject(RGN);
  end;
  SetWindowRgn(Handle,FRegion,True);
end;

function TControlDesignerFrame.MouseZone(X,Y: Integer): TMouseZone;
begin
  Result:=mzNone;
  if Y<=FThickness then
    if X<=FThickness then Result:=mzLeftTop
    else
      if X>=Width-FThickness then Result:=mzRightTop
      else
        if (X>=(Width-FThickness) div 2) and (X<=(Width+FThickness) div 2) then Result:=mzCenterTop
        else Result:=mzFrame
  else
    if Y>=Height-FThickness then
      if X<=FThickness then Result:=mzLeftBottom
      else
        if X>=Width-FThickness then Result:=mzRightBottom
        else
          if (X>=(Width-FThickness) div 2) and (X<=(Width+FThickness) div 2) then Result:=mzCenterBottom
          else Result:=mzFrame
    else
      if X<=FThickness then
        if (Y>=(Height-FThickness) div 2) and (Y<=(Height+FThickness) div 2) then Result:=mzLeftCenter
        else Result:=mzFrame
      else
        if X>=Width-FThickness then
          if (Y>=(Height-FThickness) div 2) and (Y<=(Height+FThickness) div 2) then Result:=mzRightCenter
          else Result:=mzFrame;
end;

procedure TControlDesignerFrame.DrawDragRect;
var
  ParentCanvas: TCanvas;
begin
  if Assigned(Parent) then
  begin
    ParentCanvas:=TCanvas.Create;
    with ParentCanvas do
    begin
      Handle:=GetDCEx(Parent.Handle,0,DCX_CACHE or DCX_CLIPSIBLINGS or DCX_PARENTCLIP);
      try
        with Pen do
        begin
          Style:=psSolid;
          Mode:=pmXor;
          Width:=2;
          Color:=clGray;
        end;
        Brush.Style:=bsClear;
        with FDragRect do Rectangle(Left+1,Top+1,Right,Bottom);
      finally
        ReleaseDC(0,ParentCanvas.Handle);
        ParentCanvas.Handle:=0;
      end;
    end;
  end;
end;

procedure TControlDesignerFrame.ShowDragHint(AHint: string);
var
  R: TRect;
  P: TPoint;
begin
  if FShowMoveSizeHint then
    with FHintWindow do
    begin
      R:=CalcHintRect(255,AHint,nil);
      GetCursorPos(P);
      OffsetRect(R,P.X,P.Y+12);
      ActivateHint(R,AHint);
    end;
end;

procedure TControlDesignerFrame.HideDragHint;
begin
  FHintWindow.ReleaseHandle;
end;

function TControlDesignerFrame.GetDesigner: TCustomControlDesigner;
begin
  if Assigned(Owner) and (Owner is TCustomControlDesigner) then
    Result:=TCustomControlDesigner(Owner)
  else Result:=nil;
end;

procedure TControlDesignerFrame.SetControl(const Value: TControl);
var
  Allow: Boolean;
begin
  if (csDesigning in ComponentState) or not Assigned(Designer) or not Designer.Active then
  begin
    FControl:=Value;
    Visible:=False;
  end
  else
  begin
    Allow:=True;
    if Assigned(Designer) and Assigned(Designer.OnAllowSelectControl) then
      Designer.OnAllowSelectControl(Designer,Value,Allow);
    if Allow then
    begin
      FControl:=Value;
      Visible:=Assigned(FControl);
      UpdatePosition;
      if Assigned(Designer) and Assigned(Designer.OnSelectControl) then
        Designer.OnSelectControl(Designer,FControl);
      if FEnableKeys and Showing and CanFocus then SetFocus;
    end;
  end;
end;

procedure TControlDesignerFrame.SetThickness(const Value: Integer);
begin
  if Value<>FThickness then
  begin
    FThickness:=Value;
    UpdatePosition;
  end;
end;

procedure TControlDesignerFrame.SetBorderColor(const Value: TColor);
begin
  if Value<>FBorderColor then
  begin
    FBorderColor:=Value;
    Invalidate;
  end;
end;

procedure TControlDesignerFrame.SetFrameColor(const Value: TColor);
begin
  if Value<>FFrameColor then
  begin
    FFrameColor:=Value;
    Invalidate;
  end;
end;

procedure TControlDesignerFrame.SetGrabColor(const Value: TColor);
begin
  if Value<>FGrabColor then
  begin
    FGrabColor:=Value;
    Invalidate;
  end;
end;

procedure TControlDesignerFrame.SetEnableKeys(const Value: Boolean);
begin
  FEnableKeys:=Value;
  if FEnableKeys and Showing and CanFocus then SetFocus;
end;

procedure TControlDesignerFrame.CreateHandle;
begin
  inherited;
  UpdatePosition;
end;

procedure TControlDesignerFrame.Paint;
var
  T: Integer;
begin
  with Canvas do
  begin
    Pen.Color:=FBorderColor;
    Brush.Color:=FFrameColor;
    Rectangle(0,0,Width,Height);
    Rectangle(Pred(FThickness),Pred(FThickness),Width-Pred(FThickness),Height-Pred(FThickness));
    Brush.Color:=FGrabColor;
    T:=FThickness;
    Rectangle((Width-T) div 2,0,(Width+T) div 2,T);
    Rectangle((Width-T) div 2,(Height-T),(Width+T) div 2,Height);
    Rectangle(0,(Height-T) div 2,T,(Height+T) div 2);
    Rectangle(Width-T,(Height-T) div 2,Width,(Height+T) div 2);
    Rectangle(0,0,T,T);
    Rectangle(Width-T,0,Width,T);
    Rectangle(0,Height-T,T,Height);
    Rectangle(Width-T,Height-T,Width,Height);
  end;
end;

procedure TControlDesignerFrame.WndProc(var Message: TMessage);
var
  P: TPoint;
  R: TRect;
  X,Y,Step: Integer;
  Shift: Boolean;