如何在程序运行期设计窗体中的控件, 就像在Delphi中设计窗体中的控件一样?

[wafeijian]

如何在程序运行期设计窗体中的控件, 就像在Delphi中设计窗体中的控件一样?
移动,改变大小等; 最重要的是这些控件表现形态要和设计期类似, 即不能获得焦点, 不能响应鼠标事件等. 例如TEdit不可以输入信息, TRadioGroup不可以改变缺省选中的项等.

[wafeijian]

谢谢各位!
最近要做一个让用户自定义报表界面的功能, 要做得好一点可能是比较麻烦, 所以需要大家多指教!
我试用了一下一个TResizer的控件, 用这个控件之后, 对当前选中待设计的控件没有问题, 但关键在于选中的过程中有些控件无法使其表现形态和设计期类似.(拖动过程中也有一些BUG).
如TRadioGroup控件, 还可以在各个选项中进行选择.

[steelxu5]

mark

[wafeijian]

頂上去.

[Comer]

顶

[dejoy]

使用现成的控件吧，在这些控件包中有：
Extlib,dreamCtrls,lmd.

自己写也可以，有一个IdesingerHook接口，自己实现。我原来也写过，比较复杂。

[jiawei6682]

这有点困难了，没试过

[yeeyee]

1、对象创建释放机制
2、PME ，属性编辑器，
的控件存到自己的文件中。相当于 dfm 文件
3、将代码分割到 bpl 文件中。
不知道说得对不对。
顶

[yuejun]

顶

[befree]

既然是自定义报表，当然就用报表设计工具
想得太复杂，学生做毕业设计吧

[godear]

何须如此, 用fastreport设计比较方便

[chenylin]

我测试做了一个,基本上可以满足你的要求,可以动态生成控件,可以设置大小及位置,同时可以返回四个值,
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ToolWin, StdCtrls, Spin, Menus;

type
TForm1 = class(TForm)
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
SpinEditW: TSpinEdit;
SpinEditH: TSpinEdit;
SpinEditL: TSpinEdit;
SpinEditT: TSpinEdit;
PopupMenuSet: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
procedure ToolButton1Click(Sender: TObject);
procedure proMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure N1Click(Sender: TObject);
procedure N2Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
pos:string;
implementation

{$R *.dfm}

procedure TForm1.ToolButton1Click(Sender: TObject);
var
AEdit:TEdit;
begin
AEdit:=TEdit.Create(self);
AEdit.Top:=30;
AEdit.Left:=30;
AEdit.Width:=30;
AEdit.Height:=20;
AEdit.Parent:=self;
AEdit.ReadOnly:=true;
AEdit.OnMouseDown:=proMouseDown;
AEdit.PopupMenu:=PopupMenuSet;
end;

procedure TForm1.proMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
//可以拖动生成的控件
ReleaseCapture;
TEdit(Sender).Perform(WM_SYSCOMMAND,$f012,0);
//显示四个值
SpinEditW.Text:=InttoStr(TEdit(Sender).Width);
SpinEditH.Text:=InttoStr(TEdit(Sender).Height);
SpinEditL.Text:=InttoStr(TEdit(Sender).Left);
SpinEditT.Text:=InttoStr(TEdit(Sender).Top);
end;

procedure TForm1.N1Click(Sender: TObject);
begin
pos:=Inttostr(TEdit(PopupMenuSet.PopupComponent).Left);
if InputQuery('设置左距','',pos) then TEdit(PopupMenuSet.PopupComponent).Left:=Strtoint(pos);
end;

procedure TForm1.N2Click(Sender: TObject);
begin
pos:=Inttostr(TEdit(PopupMenuSet.PopupComponent).Top);
if InputQuery('设置顶距','',pos) then TEdit(PopupMenuSet.PopupComponent).Top:=Strtoint(pos);
end;

procedure TForm1.N3Click(Sender: TObject);
begin
pos:=Inttostr(TEdit(PopupMenuSet.PopupComponent).Width);
if InputQuery('设置宽度','',pos) then TEdit(PopupMenuSet.PopupComponent).Width:=Strtoint(pos);
end;

procedure TForm1.N4Click(Sender: TObject);
begin
pos:=Inttostr(TEdit(PopupMenuSet.PopupComponent).Height);
if InputQuery('设置高度','',pos) then TEdit(PopupMenuSet.PopupComponent).Height:=Strtoint(pos);
end;

procedure TForm1.N5Click(Sender: TObject);//删除控件
begin
PopupMenuSet.PopupComponent.Free;
end;

end.

[qiujsh]

可以改变控件大小的
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure ManipulateControl(Control: TControl; Shift: TShiftState; X, Y, Precision: integer);
var SC_MANIPULATE: Word;
begin
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的最左侧**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if (X<=Precision) and (Y>Precision) and (Y<Control.Height-Precision)
then begin
SC_MANIPULATE := $F001;
Control.Cursor := crSizeWE;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的最右侧**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>=Control.Width-Precision) and (Y>Precision) and (Y<Control.Height-Precision)
then begin
SC_MANIPULATE := $F002;
Control.Cursor := crSizeWE;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的最上侧**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>Precision) and (X<Control.Width-Precision) and (Y<=Precision)
then begin
SC_MANIPULATE := $F003;
Control.Cursor := crSizeNS;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的左上角**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X<=Precision) and (Y<=Precision)
then begin
SC_MANIPULATE := $F004;
Control.Cursor := crSizeNWSE;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的右上角**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>=Control.Width-Precision) and (Y<=Precision)
then begin
SC_MANIPULATE := $F005;
Control.Cursor := crSizeNESW ;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的最下侧**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>Precision) and (X<Control.Width-Precision) and (Y>=Control.Height-Precision)
then begin
SC_MANIPULATE := $F006;
Control.Cursor := crSizeNS;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的左下角**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X<=Precision) and (Y>=Control.Height-Precision)
then begin
SC_MANIPULATE := $F007;
Control.Cursor := crSizeNESW;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的右下角**********************************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>=Control.Width-Precision) and (Y>=Control.Height-Precision)
then begin
SC_MANIPULATE := $F008;
Control.Cursor := crSizeNWSE;
end
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//光标在控件的客户区（移动整个控件）******************************************
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
else if (X>5) and (Y>5) and (X<Control.Width-5) and (Y<Control.Height-5)
then begin
SC_MANIPULATE := $F009;
Control.Cursor := crSizeAll;
end
else begin
SC_MANIPULATE := $F000;
Control.Cursor := crDefault;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Shift=[ssLeft] then
begin
ReleaseCapture;
Control.Perform(WM_SYSCOMMAND, SC_MANIPULATE, 0);
end;
end;



procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Caption := IntToStr(X) + '/' + IntToStr(Y);
ManipulateControl((Sender as TControl), Shift, X, Y, 10);
end;

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Caption := IntToStr(X) + '/' + IntToStr(Y);
ManipulateControl((Sender as TControl), Shift, X, Y, 10);
end;

end.

[Heyongfeng]

帮顶

[wafeijian]

谢谢各位! 特别是chenylin(陈SIR), qiujsh(scsoft.agrie.com)
不过chenylin(陈SIR)的方法只可以动态移动控件(TEdit(Sender).Perform(WM_SYSCOMMAND,$f012,0);), 而不可以改变大小.

qiujsh(scsoft.agrie.com) 的方法我也试过, 有一些小BUG, 如有时移到下边框时有些问题.

我现在已基本实现了这些功能, 但还不可以多选. 不知那位兄台有高见.

我听说有一种方法是在动态创建控件时可设定使控件不响应任何消息, 这时可通过取得光标所在位置的控件来选中它, 但不知具体做法, 有没有知道的啊.

[Blakhawk]

qiujsh(scsoft.agrie.com)强人啊。

[Blakhawk]

能不能在拖动的时候象DELPHI的设计环境一样，使得控件是处于设计状态或者伪设计状态，显示四个角的选择状态。

[wafeijian]

主要用到了下面一个控件, 在网上找的, 大家看看. 再配合一些消息截获就可以实现控件的任意移动及改变大小, 而且不响应多余的事件, 使其和设计基本一致. 但还没实现多选啊.

unit Resizer;

interface

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

const
GRIDDEFAULT = 4;

type
TResizer = class;
TMover = class;

TMovingEvent = procedure(Sender: TResizer; var NewLeft, NewTop: integer) of object;
TSizingEvent = procedure(Sender: TResizer; var NewLeft, NewTop, NewWidth, NewHeight: integer) of object;

TResizer = class(TComponent)
protected
FActive : boolean;
FControl : TControl;
Sizers : TList;
GroupMovers : TList;
FGroup : TWinControl;
FGridX : integer;
FGridY : integer;
FOnSized : TNotifyEvent;
FOnSizing : TSizingEvent;
FOnMoved : TNotifyEvent;
FOnMoving : TMovingEvent;
Sizing : boolean;
Moving : boolean;
OrigSize : TRect;
NewSize : TRect;
DownX : integer;
DownY : integer;
FAllowSize : boolean;
FAllowMove : boolean;
FKeepIn : boolean;
FHotTrack : boolean;
OneMover : TMover;
CurMover : TMover;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure SetActive(b: boolean);
procedure SetControl(c: TControl);
procedure SetGroup(p: TWinControl);
procedure CreateSizers;
procedure CheckSizers;
procedure ShowSizers;
procedure HideSizers;
procedure SizerDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure SizerUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure SizerMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure MoverDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure MoverUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure MoverMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure DrawSizeRect(Rect: TRect);
procedure Calc_Size_Rect(SizerNum, dx, dy: integer);
procedure DoSizingEvent;
procedure Calc_Move_Rect(dx, dy: integer);
procedure DoMovingEvent;
procedure Constrain_Size;
procedure Constrain_Move;
procedure MoverKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure DoSizeMove(var Key: Word; Shift: TShiftState; dx, dy: integer);
procedure CreateGroupMovers;
procedure CreateOneMover(m: TMover; c: TControl);
function FindMoverByBuddy(c: TControl): TMover;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Active: boolean read FActive write SetActive default True;
property ResizeControl: TControl read FControl write SetControl;
property ResizeGroup: TWinControl read FGroup write SetGroup;
property GridX: integer read FGridX write FGridX default GRIDDEFAULT;
property GridY: integer read FGridY write FGridY default GRIDDEFAULT;
property OnSized: TNotifyEvent read FOnSized write FOnSized;
property OnSizing: TSizingEvent read FOnSizing write FOnSizing;
property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
property OnMoving: TMovingEvent read FOnMoving write FOnMoving;
property AllowSize: boolean read FAllowSize write FAllowSize default True;
property AllowMove: boolean read FAllowMove write FAllowMove default True;
property KeepInParent: boolean read FKeepIn write FKeepIn default True;
property HotTrack: boolean read FHotTrack write FHotTrack;
end;

TInvisWin = class(TPanel) // This could also derive from TPanel
protected
procedure WndProc(var Message: TMessage); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure WMDLGCode(var Message: TMessage); message WM_GETDLGCODE;
public
property OnKeyDown;
end;

TMover = class(TInvisWin)
public
Buddy : TControl;
procedure Show;
end;


//procedure Register;

implementation

const
SIZE = 6;
HALFSIZE = SIZE div 2;

type
TSizer = class(TPanel)
end;

//procedure Register;
//begin
// RegisterComponents('Cyc', [TResizer]);
//end;

[wafeijian]

// *****************************************************************
// TInvisWin

procedure TInvisWin.WndProc(var Message: TMessage);
var
ps : TPaintStruct;
begin
case Message.Msg of
WM_ERASEBKGND: Message.Result := 1;
WM_PAINT: begin
BeginPaint(Handle, ps);
EndPaint(Handle, ps);
Message.Result := 1;
end;
else
inherited WndProc(Message);
end;
end;

procedure TInvisWin.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TInvisWin.WMDLGCode(var Message: TMessage);
begin
Message.Result := DLGC_WANTARROWS or DLGC_WANTALLKEYS;
end;


// *****************************************************************
// TMover

procedure TMover.Show;
begin
Assert(Buddy <> nil);
BoundsRect := Buddy.BoundsRect;
Parent := Buddy.Parent;
Visible := True;
BringToFront;
end;


// *****************************************************************
// TResizer

constructor TResizer.Create(AOwner: TComponent);
begin
inherited;
FActive := True;
FKeepIn := True;
FGridX := GRIDDEFAULT;
FGridY := GRIDDEFAULT;
FAllowSize := True;
FAllowMove := True;
GroupMovers := TList.Create;
Sizers := TList.Create;

OneMover := TMover.Create(Self);
CreateOneMover(OneMover, nil);

CreateSizers;
end;

destructor TResizer.Destroy;
begin
GroupMovers.Free;
Sizers.Free;
Sizers := nil;
inherited;
end;

procedure TResizer.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if csDestroying in ComponentState then exit;
if (AComponent = ResizeControl) and (Operation = opRemove) then
ResizeControl := nil;
end;

procedure TResizer.SetActive(b: boolean);
begin
if b<>FActive then begin
FActive := b;
CheckSizers;
end;
end;

procedure TResizer.SetControl(c: TControl);
begin
if c <> FControl then begin

if c<>nil then begin
if ResizeGroup<>nil then begin
Assert(c.Parent = ResizeGroup, 'ResizeControl is not in ResizeGroup!');
CurMover := FindMoverByBuddy(c);
end else begin
CurMover := OneMover;
CurMover.Buddy := c;
end;
CurMover.Show;
end;

FControl := c;
CheckSizers;
end;
end;

procedure TResizer.SetGroup(p: TWinControl);
begin
if p <> FGroup then begin
FGroup := p;
CreateGroupMovers;
end;
end;

procedure TResizer.CreateGroupMovers;
var
i : integer;
m : TMover;
c : TControl;
begin
if csDesigning in ComponentState then exit;

// Clear out the old Movers
for i := 0 to GroupMovers.Count-1 do
TObject(GroupMovers[i]).Free;
GroupMovers.Clear;

if ResizeGroup <> nil then begin
for i := 0 to ResizeGroup.ControlCount-1 do begin
c := ResizeGroup.Controls[i];
if (c is TMover) or (c is TSizer) then continue;

m := TMover.Create(Self);
CreateOneMover(m, c);
GroupMovers.Add(m);
m.Show;
end;
end;
end;

procedure TResizer.CreateSizers;
var
i : integer;
p : TSizer;
begin
if csDesigning in ComponentState then exit;

for i := 0 to 7 do begin
p := TSizer.Create(Self);
Sizers.Add(p);

p.BevelOuter := bvNone;
p.Width := SIZE;
p.Height := SIZE;
p.Color := clBlack;
p.Caption := '';
p.Tag := i;
p.OnMouseDown := SizerDown;
p.OnMouseUp := SizerUp;
p.OnMouseMove := SizerMove;
p.TabStop := False;

case i of
0, 7 : p.Cursor := crSizeNWSE;
2, 5 : p.Cursor := crSizeNESW;
1, 6 : p.Cursor := crSizeNS;
3, 4 : p.Cursor := crSizeWE;
end;
end;
end;

procedure TResizer.CreateOneMover(m: TMover; c: TControl);
begin
m.OnMouseDown := MoverDown;
m.OnMouseUp := MoverUp;
m.OnMouseMove := MoverMove;
m.TabStop := True;
m.OnKeyDown := MoverKeyDown;
m.Buddy := c;
end;

procedure TResizer.CheckSizers;
begin
if (ResizeControl<>nil) and Active and (not (csDesigning in ComponentState)) then
ShowSizers
else
HideSizers;
end;

procedure TResizer.ShowSizers;
var
i : integer;
p : TPanel;
c : TControl;
begin
c := ResizeControl;
Assert(c <> nil);

for i := 0 to 7 do begin
p := TPanel(Sizers[i]);
case i of
0, 1, 2 : p.Top := c.Top - HALFSIZE;
3, 4 : p.Top := c.Top + c.Height div 2 - HALFSIZE;
5, 6, 7 : p.Top := c.Top + c.Height - HALFSIZE;
end;

case i of
0, 3, 5 : p.Left := c.Left - HALFSIZE;
1, 6 : p.Left := c.Left + c.Width div 2 - HALFSIZE;
2, 4, 7 : p.Left := c.Left + c.Width - HALFSIZE;
end;
end;

Assert(CurMover<>nil);
CurMover.Show;

for i := 0 to Sizers.Count-1 do begin
p := TPanel(Sizers[i]);
p.Parent := c.Parent;
p.Visible := True;
p.BringToFront;
end;

if CurMover.HandleAllocated and CurMover.CanFocus then
CurMover.SetFocus;
end;

procedure TResizer.HideSizers;
var
i : integer;
p : TPanel;
begin
for i := 0 to Sizers.Count-1 do begin
p := TPanel(Sizers[i]);
p.Visible := False;
p.Update;
end;
OneMover.Visible := False;
end;

procedure TResizer.SizerDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Sizing := True;
DownX := X;
DownY := Y;
HideSizers;
ResizeControl.Parent.Update;
ResizeControl.Update;
OrigSize := ResizeControl.BoundsRect;
NewSize := OrigSize;
DrawSizeRect(NewSize);
end;

[wafeijian]

procedure DoSwap(DoSwap: boolean; var a, b: integer);
var
t : integer;
begin
if DoSwap then begin
t := a;
a := b;
b := t;
end;
end;

procedure TResizer.SizerUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if NewSize.Right < NewSize.Left then
DoSwap(True, NewSize.Right, NewSize.Left);
if NewSize.Bottom < NewSize.Top then
DoSwap(True, NewSize.Bottom, NewSize.Top);

Sizing := False;
DrawSizeRect(NewSize);
ResizeControl.Invalidate;
ResizeControl.BoundsRect := NewSize;
ShowSizers;
if Assigned(OnSized) then OnSized(Self);
end;

procedure TResizer.SizerMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Sizing then begin
DrawSizeRect(NewSize);

if AllowSize then begin
Calc_Size_Rect((Sender as TSizer).Tag, X - DownX, Y - DownY);
DoSizingEvent;
end;

DrawSizeRect(NewSize);
if HotTrack then ResizeControl.BoundsRect := NewSize;
end;
end;

procedure TResizer.DoSizingEvent;
var
tmpWid, tmpHgt : integer;
begin
tmpWid := NewSize.Right - NewSize.Left;
tmpHgt := NewSize.Bottom - NewSize.Top;
if Assigned(OnSizing) then
OnSizing(Self, NewSize.Left, NewSize.Top, tmpWid, tmpHgt);
NewSize.Right := NewSize.Left + tmpWid;
NewSize.Bottom := NewSize.Top + tmpHgt;
end;

procedure GetNonClientOffset(h: THandle; var nx, ny: integer);
var
p : TPoint;
R : TRect;
begin
p := Point(0, 0);
Windows.ClientToScreen(h, p);
Windows.GetWindowRect(h, R);
nx := p.x - R.Left;
ny := p.y - R.Top;
end;

procedure TResizer.DrawSizeRect(Rect: TRect);
var
h : THandle;
dc : THandle;
c : TCanvas;
nx, ny : integer;
OldPen : TPen;
OldBrush : TBrush;
begin
if HotTrack then exit;

h := (ResizeControl.Parent as TWinControl).Handle;
GetNonClientOffset(h, nx, ny);
dc := GetWindowDC(h);
try
c := TCanvas.Create;
c.Handle := dc;

OldPen := TPen.Create;
OldPen.Assign(c.Pen);
OldBrush := TBrush.Create;
OldBrush.Assign(c.Brush);

c.Pen.Width := 2;
c.Pen.Mode := pmXOR;
c.Pen.Color := clWhite;
c.Brush.Style := bsClear;
c.Rectangle(Rect.Left + nx, Rect.Top + ny, Rect.Right + nx, Rect.Bottom + ny);

c.Pen.Assign(OldPen);
OldPen.Free;
c.Brush.Assign(OldBrush);
OldBrush.Free;

c.Handle := 0;
c.Free;
finally
ReleaseDC(h, dc);
end;
end;

procedure TResizer.Calc_Size_Rect(SizerNum, dx, dy: integer);
begin
dx := (dx div GridX) * GridX;
dy := (dy div GridY) * GridY;

case SizerNum of
0, 1, 2 : NewSize.Top := OrigSize.Top + dy;
5, 6, 7 : NewSize.Bottom := OrigSize.Bottom + dy;
end;

case SizerNum of
0, 3, 5 : NewSize.Left := OrigSize.Left + dx;
2, 4, 7 : NewSize.Right := OrigSize.Right + dx;
end;

if KeepInParent then Constrain_Size;
end;

procedure TResizer.MoverDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
CurMover := Sender as TMover;
FControl := CurMover.Buddy;
Assert(FControl<>nil);
FControl.BringToFront;
CurMover.BringToFront;

Moving := True;
DownX := X;
DownY := Y;
HideSizers;
ResizeControl.Parent.Update;
ResizeControl.Update;
OrigSize := ResizeControl.BoundsRect;
NewSize := OrigSize;
DrawSizeRect(NewSize);
end;

procedure TResizer.MoverUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Moving := False;
ResizeControl.BoundsRect := NewSize;
CurMover.Invalidate;
ResizeControl.Refresh;
DrawSizeRect(NewSize);
ShowSizers;
if Assigned(OnMoved) then OnMoved(Self);
end;

procedure TResizer.Calc_Move_Rect(dx, dy: integer);
begin
NewSize := OrigSize;
dx := (dx div GridX) * GridX;
dy := (dy div GridY) * GridY;
OffsetRect(NewSize, dx, dy);
if KeepInParent then Constrain_Move;
end;

procedure TResizer.DoMovingEvent;
var
tmpWid, tmpHgt : integer;
begin
tmpWid := NewSize.Right - NewSize.Left;
tmpHgt := NewSize.Bottom - NewSize.Top;
if Assigned(OnMoving) then
OnMoving(Self, NewSize.Left, NewSize.Top);
NewSize.Right := NewSize.Left + tmpWid;
NewSize.Bottom := NewSize.Top + tmpHgt;
end;

procedure TResizer.MoverMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
dx, dy: integer;
begin
if Moving then begin
DrawSizeRect(NewSize);

if AllowMove then begin
dx := X - DownX;
dy := Y - DownY;
Calc_Move_Rect(dx, dy);
DoMovingEvent;
end;

DrawSizeRect(NewSize);
if HotTrack then ResizeControl.BoundsRect := NewSize;
end;
end;

procedure TResizer.Constrain_Size;
var
p : TWinControl;
begin
p := ResizeControl.Parent;

with NewSize do begin
if Left < 0 then Left := 0;
if Top < 0 then Top := 0;
if Right > p.ClientWidth then Right := p.ClientWidth;
if Bottom > p.ClientHeight then Bottom := p.ClientHeight;

if Right < Left + GridX then Right := Left + GridX;
if Bottom < Top + GridY then Bottom := Top + GridY;
end;
end;

procedure TResizer.Constrain_Move;
begin
if NewSize.Left < 0 then
OffsetRect(NewSize, -NewSize.Left, 0);

if NewSize.Top < 0 then
OffsetRect(NewSize, 0, -NewSize.Top);

if NewSize.Right > ResizeControl.Parent.ClientWidth then
OffsetRect(NewSize, ResizeControl.Parent.ClientWidth - NewSize.Right, 0);

if NewSize.Bottom > ResizeControl.Parent.ClientHeight then
OffsetRect(NewSize, 0, ResizeControl.Parent.ClientHeight - NewSize.Bottom);
end;

procedure TResizer.MoverKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Active then begin
case Key of
VK_LEFT : DoSizeMove(Key, Shift, -GridX, 0);
VK_RIGHT : DoSizeMove(Key, Shift, GridX, 0);
VK_UP : DoSizeMove(Key, Shift, 0, -GridY);
VK_DOWN : DoSizeMove(Key, Shift, 0, GridY);
end;
end;
end;

procedure TResizer.DoSizeMove(var Key: Word; Shift: TShiftState; dx, dy: integer);
begin
if (ssCtrl in Shift) or (ssShift in Shift) then begin
Key := 0;

NewSize := ResizeControl.BoundsRect;

if (ssCtrl in Shift) and AllowMove then begin
OffsetRect(NewSize, dx, dy);
if KeepInParent then Constrain_Move;
DoMovingEvent;
end;

if (ssShift in Shift) and AllowSize then begin
NewSize.Right := NewSize.Right + dx;
NewSize.Bottom := NewSize.Bottom + dy;
if KeepInParent then Constrain_Size;
DoSizingEvent;
end;

ResizeControl.BoundsRect := NewSize;
ShowSizers;
end;
end;

function TResizer.FindMoverByBuddy(c: TControl): TMover;
var
i : integer;
begin
Result := nil;
for i := 0 to GroupMovers.Count-1 do
if TMover(GroupMovers[i]).Buddy = c then
Result := GroupMovers[i];
Assert(Result <> nil);
end;

end.

[hacking]

mark