Jens Kallup
2014-05-15 19:56:11 UTC
Hallo,
die ActiveX Erstellung klappt.
Das Ergenbins anzeigen auch.
Leider funktioniert das Move event nicht so recht wie es soll.
Hier der Quellcode, für Feedback bin ich euch dankbar ...
unit SsCtrlSize;
interface
uses
{$IFDEF VER80}
WinTypes, WinProcs,
{$ELSE}
Windows,
{$ENDIF}
Forms, Messages, SysUtils, Classes, Graphics, Controls;
type
TssGrabHandlePosition = (ghTopLeft, ghTopMiddle, ghTopRight,
ghRightMiddle,
ghBottomRight, ghBottomMiddle, ghBottomLeft, ghLeftMiddle);
TssPositiveInteger = 0..MaxInt;
TssGrabEvent = procedure(Sender: TObject; sx, sy: integer) of object;
TssSizeAndMoveEvent = procedure(Sender: TObject; rct: TRect) of object;
TssGrabHandle = class(TCustomControl)
private
FCaptured: boolean;
FControl: TControl;
FHandlePosition: TssGrabHandlePosition;
FOnDrag: TssGrabEvent;
FOnEndDrag: TssGrabEvent;
FOnStartDrag: TssGrabEvent;
FVisible: boolean;
procedure SetControl(const c: TControl);
procedure SetHandlePosition(const p: TssGrabHandlePosition);
procedure SetPosition;
procedure SetVisible(const v: boolean);
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure WmMouseDown(var msg: TWmLButtonDown); message WM_LBUTTONDOWN;
procedure WmMouseMove(var msg: TWmMouseMove); message WM_MOUSEMOVE;
procedure WmMouseUp(var msg: TWmLButtonUp); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
procedure ResetPosition;
property Control: TControl read FControl write SetControl;
property HandlePosition: TssGrabHandlePosition read FHandlePosition
write SetHandlePosition;
property Visible: boolean read FVisible write SetVisible;
property OnDrag: TssGrabEvent read FOnDrag write FOnDrag;
property OnEndDrag: TssGrabEvent read FOnEndDrag write FOnEndDrag;
property OnStartDrag: TssGrabEvent read FOnStartDrag write
FOnStartDrag;
end;
TssControlSizer = class(TComponent)
private
FAllowMove: boolean;
FAllowResize: boolean;
FCanvas: TCanvas;
FControl: TControl;
FGrabHandles: array[TssGrabHandlePosition] of TssGrabHandle;
FLastSizeRect: TRect;
FLimitToParentRect: boolean;
FMinimumMove: TssPositiveInteger;
FMoved: boolean;
FMoving: boolean;
FNewWndProc: Pointer;
FOldWndProc: Pointer;
FOnEndMove: TNotifyEvent;
FOnEndSize: TNotifyEvent;
FOnStartMove: TNotifyEvent;
FOnStartSize: TNotifyEvent;
FParentControl: TWinControl;
FParentRect: TRect;
FStartMovePos: TPoint;
FOnSize: TssSizeAndMoveEvent;
FOnMove: TssSizeAndMoveEvent;
procedure DoSubclass;
procedure DrawMoveRect(const sx, sy: integer);
procedure DrawSizeRect(Sender: TObject; sx, sy: integer);
procedure EndMoveControl(const x, y: Smallint);
procedure FreeCanvas;
procedure GetCanvas;
function GetControlBoundsRect(Sender: TObject; sx, sy: integer): TRect;
function LimitPointToParent(const pt: TPoint): TPoint;
function LimitRectToParent(const rct: TRect): TRect;
procedure MoveControl(const x, y: Smallint);
procedure OnDragHandle(Sender: TObject; sx, sy: integer);
procedure OnEndDragHandle(Sender: TObject; sx, sy: integer);
procedure OnStartDragHandle(Sender: TObject; sx, sy: integer);
procedure SetAllowMove(const v: boolean);
procedure SetAllowResize(const v: boolean);
procedure SetControl(const c: TControl);
procedure SetVisible(const v: boolean);
procedure StartMoveControl(const x, y: Smallint);
procedure UnDoSubclass;
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure ReSetHandles;
procedure SubclassProc(var msg: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
published
property AllowMove: boolean read FAllowMove write SetAllowMove
default true;
property AllowResize: boolean read FAllowResize write
SetAllowResize default true;
property Control: TControl read FControl write SetControl;
property LimitToParentRect: boolean read FLimitToParentRect write
FLimitToParentRect default false;
property MinimumMove: TssPositiveInteger read FMinimumMove write
FMinimumMove default 3;
property OnStartSize: TNotifyEvent read FOnStartSize write
FOnStartSize;
property OnSize: TssSizeAndMoveEvent read FOnSize write FOnSize;
property OnEndSize: TNotifyEvent read FOnEndSize write FOnEndSize;
property OnStartMove: TNotifyEvent read FOnStartMove write
FOnStartMove;
property OnMove: TssSizeAndMoveEvent read FOnMove write FOnMove;
property OnEndMove: TNotifyEvent read FOnEndMove write FOnEndMove;
end;
procedure Register;
implementation
{$IFDEF WIN32}
{$R *.R32}
{$ELSE}
{$R *.R16}
{$ENDIF}
procedure Register;
begin
RegisterComponents('SadMan', [TssControlSizer]);
end;
function NormaliseRect(const rct: TRect): TRect;
begin
result := rct;
if rct.Left > rct.Right then begin
result.Left := rct.Right;
result.Right := rct.Left;
end;
if rct.Top > rct.Bottom then begin
result.Top := rct.Bottom;
result.Bottom := rct.Top;
end;
end;
function FindParent(const comp: TComponent): TWinControl;
function UpOne(const comp: TComponent): TComponent;
begin
if comp is TControl then
result := TControl(comp).Parent
else
result := comp.Owner;
end;
var
o: TComponent;
begin
result := nil;
if Assigned(comp) then begin
o := UpOne(comp);
while Assigned(o) and not (o is TWinControl) do
o := UpOne(o);
if o is TWinControl then
result := TWinControl(o);
end;
end;
{ TssGrabHandle }
const
HandleCursors: array[TssGrabHandlePosition] of TCursor = (
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE,
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE);
constructor TssGrabHandle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clBlack;
Cursor := HandleCursors[FHandlePosition];
Width := 5;
Height := 5;
inherited Visible := false;
FVisible := false;
FCaptured := false;
Parent := nil;
end;
procedure TssGrabHandle.Notification(AComponent: TComponent; AOperation:
TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssGrabHandle.ResetPosition;
begin
SetPosition;
end;
procedure TssGrabHandle.SetControl(const c: TControl);
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
FControl := c;
if Assigned(FControl) then begin
Parent := FindParent(FControl);
HandleNeeded;
SetPosition;
end else begin
DestroyWindowHandle;
Parent := nil;
end;
end;
end;
procedure TssGrabHandle.SetHandlePosition(const p: TssGrabHandlePosition);
begin
if FHandlePosition <> p then begin
FHandlePosition := p;
Cursor := HandleCursors[FHandlePosition];
SetPosition;
end;
end;
procedure TssGrabHandle.SetPosition;
var
x, y: integer;
begin
if Assigned(FControl) then begin
with FControl do
case FHandlePosition of
ghTopMiddle: begin
x := Left + Width div 2;
y := Top;
end;
ghTopRight: begin
x := Left + Width;
y := Top;
end;
ghRightMiddle: begin
x := Left + Width;
y := Top + Height div 2;
end;
ghBottomRight: begin
x := Left + Width;
y := Top + Height;
end;
ghBottomMiddle: begin
x := Left + Width div 2;
y := Top + Height;
end;
ghBottomLeft: begin
x := Left;
y := Top + Height;
end;
ghLeftMiddle: begin
x := Left;
y := Top + Height div 2;
end;
else begin
x := Left;
y := Top;
end;
end;
Left := x - Width div 2;
Top := y - Height div 2;
inherited Visible := FVisible;
end else
inherited Visible := false;
end;
procedure TssGrabHandle.SetVisible(const v: boolean);
begin
if FVisible <> v then begin
FVisible := v;
inherited Visible := FVisible and Assigned(FControl);
end;
end;
procedure TssGrabHandle.WmMouseDown(var msg: TWmLButtonDown);
var
pt: TPoint;
begin
if not FCaptured and ((MK_LBUTTON and msg.keys) <> 0) then begin
SetCaptureControl(Self);
FCaptured := true;
if Assigned(FOnStartDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnStartDrag(Self, pt.x, pt.y);
end;
end;
end;
procedure TssGrabHandle.WmMouseMove(var msg: TWmMouseMove);
var
pt: TPoint;
begin
inherited;
if FCaptured and Assigned(FOnDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnDrag(Self, pt.x, pt.y);
end;
end;
procedure TssGrabHandle.WmMouseUp(var msg: TWmLButtonUp);
var
pt: TPoint;
begin
inherited;
if FCaptured then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
if (MK_LBUTTON and msg.keys) = 0 then begin
SetCaptureControl(nil);
FCaptured := false;
if Assigned(FOnEndDrag) then
FOnEndDrag(Self, pt.x, pt.y);
end;
end;
end;
{ TssControlSizer }
constructor TssControlSizer.Create(AOwner: TComponent);
var
h: TssGrabHandlePosition;
begin
inherited Create(AOwner);
FControl := nil;
FParentControl := nil;
FNewWndProc := nil;
FOldWndProc := nil;
FAllowResize := true;
FAllowMove := true;
FStartMovePos := Point(-1, -1);
FLimitToParentRect := false;
FMinimumMove := 3;
if not (csDesigning in ComponentState) then
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition)
do begin
FGrabHandles[h] := TssGrabHandle.Create(Self);
with FGrabHandles[h] do begin
HandlePosition := h;
OnStartDrag := Self.OnStartDragHandle;
OnDrag := Self.OnDragHandle;
OnEndDrag := Self.OnEndDragHandle;
Control := Self.FControl;
Visible := Self.FAllowResize;
end;
end
else
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
FGrabHandles[h] := nil;
end;
procedure TssControlSizer.DoSubclass;
begin
if not (csDesigning in ComponentState) and (FControl is TWinControl)
then begin
UndoSubclass;
FNewWndProc := MakeObjectInstance(SubclassProc);
FOldWndProc := Pointer(GetWindowLong(TWinControl(FControl).Handle,
GWL_WNDPROC));
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FNewWndProc));
end;
end;
procedure TssControlSizer.DrawMoveRect(const sx, sy: integer);
var
l, t: integer;
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
l := FControl.Left + sx - FStartMovePos.x;
t := FControl.Top + sy - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnMove) then
FOnMove(self, rct);
end;
procedure TssControlSizer.DrawSizeRect(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnSize) then
FOnSize(self, rct);
end;
procedure TssControlSizer.EndMoveControl(const x, y: Smallint);
var
l, t: integer;
rct: TRect;
begin
if FMoving and FMoved then begin
DrawMoveRect(x, y);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawMoveRect(x, y);
FreeCanvas;
l := FControl.Left + x - FStartMovePos.x;
t := FControl.Top + y - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with rct do begin
FControl.Left := Left;
FControl.Top := Top;
end;
ReSetHandles;
if Assigned(FOnEndMove) then
FOnEndMove(self);
end;
SetVisible(FAllowResize);
FMoving := false;
ReleaseCapture;
FStartMovePos := Point(-1, -1);
end;
procedure TssControlSizer.FreeCanvas;
var
h: THandle;
begin
if Assigned(FCanvas) then begin
h := FCanvas.Handle;
FCanvas.Handle := 0;
ReleaseDC(0, h);
FCanvas.Free;
FCanvas := nil;
end;
end;
procedure TssControlSizer.GetCanvas;
var
h: THandle;
begin
h := 0;
FCanvas := TCanvas.Create;
with FCanvas do try
h := GetDC(0);
Handle := h;
with Brush do begin
Color := clBlack;
Style := bsClear;
end;
with Pen do begin
Color := clBlack;
Style := psSolid;
Mode := pmNot;
Width := 2;
end;
except
Handle := 0;
if h <> 0 then
ReleaseDC(0, h);
Free;
FCanvas := nil;
end;
end;
function TssControlSizer.GetControlBoundsRect(Sender: TObject; sx, sy:
integer): TRect;
var
pt: TPoint;
begin
pt := FParentControl.ScreenToClient(Point(sx, sy));
result := FControl.BoundsRect;
with result do
case TssGrabHandle(Sender).FHandlePosition of
ghTopLeft: begin
Left := pt.x;
Top := pt.y;
end;
ghTopMiddle: begin
Top := pt.y;
end;
ghTopRight: begin
Right := pt.x;
Top := pt.y;
end;
ghRightMiddle: begin
Right := pt.x;
end;
ghBottomRight: begin
Right := pt.x;
Bottom := pt.y;
end;
ghBottomMiddle: begin
Bottom := pt.y;
end;
ghBottomLeft: begin
Left := pt.x;
Bottom := pt.y;
end;
ghLeftMiddle: begin
Left := pt.x;
end;
end;
end;
function TssControlSizer.LimitPointToParent(const pt: TPoint): TPoint;
begin
result := pt;
with result do begin
if X < FParentRect.Left then
X := FParentRect.Left;
if X > FParentRect.Right - 1 then
X := FParentRect.Right - 1;
if Y < FParentRect.Top then
Y := FParentRect.Top;
if Y > FParentRect.Bottom - 1 then
Y := FParentRect.Bottom - 1;
end;
end;
function TssControlSizer.LimitRectToParent(const rct: TRect): TRect;
begin
result := rct;
if result.Left < FParentRect.Left then begin
result.Left := FParentRect.Left;
result.Right := FParentRect.Left + FControl.Width;
end;
if result.Right > FParentRect.Right - 1 then begin
result.Left := FParentRect.Right - FControl.Width - 1;
result.Right := FParentRect.Right - 1;
end;
if result.Top < FParentRect.Top then begin
result.Top := FParentRect.Top;
result.Bottom := FParentRect.Top + FControl.Height;
end;
if result.Bottom > FParentRect.Bottom - 1 then begin
result.Top := FParentRect.Bottom - FControl.Height - 1;
result.Bottom := FParentRect.Bottom - 1;
end;
end;
procedure TssControlSizer.MoveControl(const x, y: Smallint);
begin
if not FMoving then exit;
if not FMoved then begin
FMoved := (abs(x - FStartMovePos.x) >= FMinimumMove) or
(abs(y - FStartMovePos.y) >= FMinimumMove);
if FMoved then begin
GetCanvas;
if Assigned(FOnStartMove) then
FOnStartMove(self);
end;
end;
if FMoved then
DrawMoveRect(x, y);
end;
procedure TssControlSizer.Notification(AComponent: TComponent;
AOperation: TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssControlSizer.OnDragHandle(Sender: TObject; sx, sy: integer);
begin
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.OnEndDragHandle(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) then exit;
DrawSizeRect(Sender, sx, sy);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
FreeCanvas;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with rct do
FControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
ReSetHandles;
SetVisible(true); { must have been visible to start dragging }
if Assigned(FOnEndSize) then
FOnEndSize(Self);
end;
procedure TssControlSizer.OnStartDragHandle(Sender: TObject; sx, sy:
integer);
begin
if Assigned(FOnStartSize) then
FOnStartSize(Self);
SetVisible(false);
{ if Assigned(FControl.Parent) then}
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
GetCanvas;
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.ReSetHandles;
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
begin
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].ResetPosition;
end;
end;
procedure TssControlSizer.SetAllowMove(const v: boolean);
begin
if FAllowMove <> v then begin
FAllowMove := v;
if not (csDesigning in ComponentState) then begin
if FAllowMove then
DoSubclass
else
UnDoSubclass;
end;
end;
end;
procedure TssControlSizer.SetAllowResize(const v: boolean);
begin
if FAllowResize <> v then begin
FAllowResize := v;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetControl(const c: TControl);
var
h: TssGrabHandlePosition;
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
UnDoSubclass;
SetVisible(false);
FControl := c;
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Control := FControl;
DoSubclass;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetVisible(const v: boolean);
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Visible := v;
end;
procedure TssControlSizer.StartMoveControl(const x, y: Smallint);
begin
if FStartMovePos.X <> -1 then exit;
FStartMovePos := Point(x, y);
FParentControl := FindParent(FControl);
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
FLastSizeRect := rect(-1, -1, -1, -1);
FMoved := false;
FMoving := true;
SetCapture(TWinControl(FControl).Handle);
SetVisible(false);
if FControl.Parent <> nil then
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
end;
procedure TssControlSizer.SubclassProc(var msg: TMessage);
begin
if FAllowMove and (msg.msg = WM_LBUTTONDOWN) then begin
{$R-}
StartMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_LBUTTONUP) then begin
{$R-}
EndMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_MOUSEMOVE) then begin
{$R-}
MoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else
msg.Result := CallWindowProc(FOldWndProc,
TWinControl(FControl).Handle, Msg.Msg, Msg.wParam, Msg.lParam);
if msg.Msg = WM_DESTROY then
UndoSubclass
else if msg.Msg = WM_WINDOWPOSCHANGED then
ReSetHandles;
end;
procedure TssControlSizer.UndoSubclass;
begin
if (FControl is TWinControl) and Assigned(FNewWndProc) and
Assigned(FOldWndProc) then begin
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FOldWndProc));
FreeObjectInstance(FNewWndProc);
FNewWndProc := nil;
FOldWndProc := nil;
end;
end;
end.
die ActiveX Erstellung klappt.
Das Ergenbins anzeigen auch.
Leider funktioniert das Move event nicht so recht wie es soll.
Hier der Quellcode, für Feedback bin ich euch dankbar ...
unit SsCtrlSize;
interface
uses
{$IFDEF VER80}
WinTypes, WinProcs,
{$ELSE}
Windows,
{$ENDIF}
Forms, Messages, SysUtils, Classes, Graphics, Controls;
type
TssGrabHandlePosition = (ghTopLeft, ghTopMiddle, ghTopRight,
ghRightMiddle,
ghBottomRight, ghBottomMiddle, ghBottomLeft, ghLeftMiddle);
TssPositiveInteger = 0..MaxInt;
TssGrabEvent = procedure(Sender: TObject; sx, sy: integer) of object;
TssSizeAndMoveEvent = procedure(Sender: TObject; rct: TRect) of object;
TssGrabHandle = class(TCustomControl)
private
FCaptured: boolean;
FControl: TControl;
FHandlePosition: TssGrabHandlePosition;
FOnDrag: TssGrabEvent;
FOnEndDrag: TssGrabEvent;
FOnStartDrag: TssGrabEvent;
FVisible: boolean;
procedure SetControl(const c: TControl);
procedure SetHandlePosition(const p: TssGrabHandlePosition);
procedure SetPosition;
procedure SetVisible(const v: boolean);
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure WmMouseDown(var msg: TWmLButtonDown); message WM_LBUTTONDOWN;
procedure WmMouseMove(var msg: TWmMouseMove); message WM_MOUSEMOVE;
procedure WmMouseUp(var msg: TWmLButtonUp); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
procedure ResetPosition;
property Control: TControl read FControl write SetControl;
property HandlePosition: TssGrabHandlePosition read FHandlePosition
write SetHandlePosition;
property Visible: boolean read FVisible write SetVisible;
property OnDrag: TssGrabEvent read FOnDrag write FOnDrag;
property OnEndDrag: TssGrabEvent read FOnEndDrag write FOnEndDrag;
property OnStartDrag: TssGrabEvent read FOnStartDrag write
FOnStartDrag;
end;
TssControlSizer = class(TComponent)
private
FAllowMove: boolean;
FAllowResize: boolean;
FCanvas: TCanvas;
FControl: TControl;
FGrabHandles: array[TssGrabHandlePosition] of TssGrabHandle;
FLastSizeRect: TRect;
FLimitToParentRect: boolean;
FMinimumMove: TssPositiveInteger;
FMoved: boolean;
FMoving: boolean;
FNewWndProc: Pointer;
FOldWndProc: Pointer;
FOnEndMove: TNotifyEvent;
FOnEndSize: TNotifyEvent;
FOnStartMove: TNotifyEvent;
FOnStartSize: TNotifyEvent;
FParentControl: TWinControl;
FParentRect: TRect;
FStartMovePos: TPoint;
FOnSize: TssSizeAndMoveEvent;
FOnMove: TssSizeAndMoveEvent;
procedure DoSubclass;
procedure DrawMoveRect(const sx, sy: integer);
procedure DrawSizeRect(Sender: TObject; sx, sy: integer);
procedure EndMoveControl(const x, y: Smallint);
procedure FreeCanvas;
procedure GetCanvas;
function GetControlBoundsRect(Sender: TObject; sx, sy: integer): TRect;
function LimitPointToParent(const pt: TPoint): TPoint;
function LimitRectToParent(const rct: TRect): TRect;
procedure MoveControl(const x, y: Smallint);
procedure OnDragHandle(Sender: TObject; sx, sy: integer);
procedure OnEndDragHandle(Sender: TObject; sx, sy: integer);
procedure OnStartDragHandle(Sender: TObject; sx, sy: integer);
procedure SetAllowMove(const v: boolean);
procedure SetAllowResize(const v: boolean);
procedure SetControl(const c: TControl);
procedure SetVisible(const v: boolean);
procedure StartMoveControl(const x, y: Smallint);
procedure UnDoSubclass;
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure ReSetHandles;
procedure SubclassProc(var msg: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
published
property AllowMove: boolean read FAllowMove write SetAllowMove
default true;
property AllowResize: boolean read FAllowResize write
SetAllowResize default true;
property Control: TControl read FControl write SetControl;
property LimitToParentRect: boolean read FLimitToParentRect write
FLimitToParentRect default false;
property MinimumMove: TssPositiveInteger read FMinimumMove write
FMinimumMove default 3;
property OnStartSize: TNotifyEvent read FOnStartSize write
FOnStartSize;
property OnSize: TssSizeAndMoveEvent read FOnSize write FOnSize;
property OnEndSize: TNotifyEvent read FOnEndSize write FOnEndSize;
property OnStartMove: TNotifyEvent read FOnStartMove write
FOnStartMove;
property OnMove: TssSizeAndMoveEvent read FOnMove write FOnMove;
property OnEndMove: TNotifyEvent read FOnEndMove write FOnEndMove;
end;
procedure Register;
implementation
{$IFDEF WIN32}
{$R *.R32}
{$ELSE}
{$R *.R16}
{$ENDIF}
procedure Register;
begin
RegisterComponents('SadMan', [TssControlSizer]);
end;
function NormaliseRect(const rct: TRect): TRect;
begin
result := rct;
if rct.Left > rct.Right then begin
result.Left := rct.Right;
result.Right := rct.Left;
end;
if rct.Top > rct.Bottom then begin
result.Top := rct.Bottom;
result.Bottom := rct.Top;
end;
end;
function FindParent(const comp: TComponent): TWinControl;
function UpOne(const comp: TComponent): TComponent;
begin
if comp is TControl then
result := TControl(comp).Parent
else
result := comp.Owner;
end;
var
o: TComponent;
begin
result := nil;
if Assigned(comp) then begin
o := UpOne(comp);
while Assigned(o) and not (o is TWinControl) do
o := UpOne(o);
if o is TWinControl then
result := TWinControl(o);
end;
end;
{ TssGrabHandle }
const
HandleCursors: array[TssGrabHandlePosition] of TCursor = (
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE,
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE);
constructor TssGrabHandle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clBlack;
Cursor := HandleCursors[FHandlePosition];
Width := 5;
Height := 5;
inherited Visible := false;
FVisible := false;
FCaptured := false;
Parent := nil;
end;
procedure TssGrabHandle.Notification(AComponent: TComponent; AOperation:
TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssGrabHandle.ResetPosition;
begin
SetPosition;
end;
procedure TssGrabHandle.SetControl(const c: TControl);
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
FControl := c;
if Assigned(FControl) then begin
Parent := FindParent(FControl);
HandleNeeded;
SetPosition;
end else begin
DestroyWindowHandle;
Parent := nil;
end;
end;
end;
procedure TssGrabHandle.SetHandlePosition(const p: TssGrabHandlePosition);
begin
if FHandlePosition <> p then begin
FHandlePosition := p;
Cursor := HandleCursors[FHandlePosition];
SetPosition;
end;
end;
procedure TssGrabHandle.SetPosition;
var
x, y: integer;
begin
if Assigned(FControl) then begin
with FControl do
case FHandlePosition of
ghTopMiddle: begin
x := Left + Width div 2;
y := Top;
end;
ghTopRight: begin
x := Left + Width;
y := Top;
end;
ghRightMiddle: begin
x := Left + Width;
y := Top + Height div 2;
end;
ghBottomRight: begin
x := Left + Width;
y := Top + Height;
end;
ghBottomMiddle: begin
x := Left + Width div 2;
y := Top + Height;
end;
ghBottomLeft: begin
x := Left;
y := Top + Height;
end;
ghLeftMiddle: begin
x := Left;
y := Top + Height div 2;
end;
else begin
x := Left;
y := Top;
end;
end;
Left := x - Width div 2;
Top := y - Height div 2;
inherited Visible := FVisible;
end else
inherited Visible := false;
end;
procedure TssGrabHandle.SetVisible(const v: boolean);
begin
if FVisible <> v then begin
FVisible := v;
inherited Visible := FVisible and Assigned(FControl);
end;
end;
procedure TssGrabHandle.WmMouseDown(var msg: TWmLButtonDown);
var
pt: TPoint;
begin
if not FCaptured and ((MK_LBUTTON and msg.keys) <> 0) then begin
SetCaptureControl(Self);
FCaptured := true;
if Assigned(FOnStartDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnStartDrag(Self, pt.x, pt.y);
end;
end;
end;
procedure TssGrabHandle.WmMouseMove(var msg: TWmMouseMove);
var
pt: TPoint;
begin
inherited;
if FCaptured and Assigned(FOnDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnDrag(Self, pt.x, pt.y);
end;
end;
procedure TssGrabHandle.WmMouseUp(var msg: TWmLButtonUp);
var
pt: TPoint;
begin
inherited;
if FCaptured then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
if (MK_LBUTTON and msg.keys) = 0 then begin
SetCaptureControl(nil);
FCaptured := false;
if Assigned(FOnEndDrag) then
FOnEndDrag(Self, pt.x, pt.y);
end;
end;
end;
{ TssControlSizer }
constructor TssControlSizer.Create(AOwner: TComponent);
var
h: TssGrabHandlePosition;
begin
inherited Create(AOwner);
FControl := nil;
FParentControl := nil;
FNewWndProc := nil;
FOldWndProc := nil;
FAllowResize := true;
FAllowMove := true;
FStartMovePos := Point(-1, -1);
FLimitToParentRect := false;
FMinimumMove := 3;
if not (csDesigning in ComponentState) then
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition)
do begin
FGrabHandles[h] := TssGrabHandle.Create(Self);
with FGrabHandles[h] do begin
HandlePosition := h;
OnStartDrag := Self.OnStartDragHandle;
OnDrag := Self.OnDragHandle;
OnEndDrag := Self.OnEndDragHandle;
Control := Self.FControl;
Visible := Self.FAllowResize;
end;
end
else
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
FGrabHandles[h] := nil;
end;
procedure TssControlSizer.DoSubclass;
begin
if not (csDesigning in ComponentState) and (FControl is TWinControl)
then begin
UndoSubclass;
FNewWndProc := MakeObjectInstance(SubclassProc);
FOldWndProc := Pointer(GetWindowLong(TWinControl(FControl).Handle,
GWL_WNDPROC));
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FNewWndProc));
end;
end;
procedure TssControlSizer.DrawMoveRect(const sx, sy: integer);
var
l, t: integer;
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
l := FControl.Left + sx - FStartMovePos.x;
t := FControl.Top + sy - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnMove) then
FOnMove(self, rct);
end;
procedure TssControlSizer.DrawSizeRect(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnSize) then
FOnSize(self, rct);
end;
procedure TssControlSizer.EndMoveControl(const x, y: Smallint);
var
l, t: integer;
rct: TRect;
begin
if FMoving and FMoved then begin
DrawMoveRect(x, y);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawMoveRect(x, y);
FreeCanvas;
l := FControl.Left + x - FStartMovePos.x;
t := FControl.Top + y - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with rct do begin
FControl.Left := Left;
FControl.Top := Top;
end;
ReSetHandles;
if Assigned(FOnEndMove) then
FOnEndMove(self);
end;
SetVisible(FAllowResize);
FMoving := false;
ReleaseCapture;
FStartMovePos := Point(-1, -1);
end;
procedure TssControlSizer.FreeCanvas;
var
h: THandle;
begin
if Assigned(FCanvas) then begin
h := FCanvas.Handle;
FCanvas.Handle := 0;
ReleaseDC(0, h);
FCanvas.Free;
FCanvas := nil;
end;
end;
procedure TssControlSizer.GetCanvas;
var
h: THandle;
begin
h := 0;
FCanvas := TCanvas.Create;
with FCanvas do try
h := GetDC(0);
Handle := h;
with Brush do begin
Color := clBlack;
Style := bsClear;
end;
with Pen do begin
Color := clBlack;
Style := psSolid;
Mode := pmNot;
Width := 2;
end;
except
Handle := 0;
if h <> 0 then
ReleaseDC(0, h);
Free;
FCanvas := nil;
end;
end;
function TssControlSizer.GetControlBoundsRect(Sender: TObject; sx, sy:
integer): TRect;
var
pt: TPoint;
begin
pt := FParentControl.ScreenToClient(Point(sx, sy));
result := FControl.BoundsRect;
with result do
case TssGrabHandle(Sender).FHandlePosition of
ghTopLeft: begin
Left := pt.x;
Top := pt.y;
end;
ghTopMiddle: begin
Top := pt.y;
end;
ghTopRight: begin
Right := pt.x;
Top := pt.y;
end;
ghRightMiddle: begin
Right := pt.x;
end;
ghBottomRight: begin
Right := pt.x;
Bottom := pt.y;
end;
ghBottomMiddle: begin
Bottom := pt.y;
end;
ghBottomLeft: begin
Left := pt.x;
Bottom := pt.y;
end;
ghLeftMiddle: begin
Left := pt.x;
end;
end;
end;
function TssControlSizer.LimitPointToParent(const pt: TPoint): TPoint;
begin
result := pt;
with result do begin
if X < FParentRect.Left then
X := FParentRect.Left;
if X > FParentRect.Right - 1 then
X := FParentRect.Right - 1;
if Y < FParentRect.Top then
Y := FParentRect.Top;
if Y > FParentRect.Bottom - 1 then
Y := FParentRect.Bottom - 1;
end;
end;
function TssControlSizer.LimitRectToParent(const rct: TRect): TRect;
begin
result := rct;
if result.Left < FParentRect.Left then begin
result.Left := FParentRect.Left;
result.Right := FParentRect.Left + FControl.Width;
end;
if result.Right > FParentRect.Right - 1 then begin
result.Left := FParentRect.Right - FControl.Width - 1;
result.Right := FParentRect.Right - 1;
end;
if result.Top < FParentRect.Top then begin
result.Top := FParentRect.Top;
result.Bottom := FParentRect.Top + FControl.Height;
end;
if result.Bottom > FParentRect.Bottom - 1 then begin
result.Top := FParentRect.Bottom - FControl.Height - 1;
result.Bottom := FParentRect.Bottom - 1;
end;
end;
procedure TssControlSizer.MoveControl(const x, y: Smallint);
begin
if not FMoving then exit;
if not FMoved then begin
FMoved := (abs(x - FStartMovePos.x) >= FMinimumMove) or
(abs(y - FStartMovePos.y) >= FMinimumMove);
if FMoved then begin
GetCanvas;
if Assigned(FOnStartMove) then
FOnStartMove(self);
end;
end;
if FMoved then
DrawMoveRect(x, y);
end;
procedure TssControlSizer.Notification(AComponent: TComponent;
AOperation: TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssControlSizer.OnDragHandle(Sender: TObject; sx, sy: integer);
begin
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.OnEndDragHandle(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) then exit;
DrawSizeRect(Sender, sx, sy);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
FreeCanvas;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with rct do
FControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
ReSetHandles;
SetVisible(true); { must have been visible to start dragging }
if Assigned(FOnEndSize) then
FOnEndSize(Self);
end;
procedure TssControlSizer.OnStartDragHandle(Sender: TObject; sx, sy:
integer);
begin
if Assigned(FOnStartSize) then
FOnStartSize(Self);
SetVisible(false);
{ if Assigned(FControl.Parent) then}
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
GetCanvas;
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.ReSetHandles;
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
begin
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].ResetPosition;
end;
end;
procedure TssControlSizer.SetAllowMove(const v: boolean);
begin
if FAllowMove <> v then begin
FAllowMove := v;
if not (csDesigning in ComponentState) then begin
if FAllowMove then
DoSubclass
else
UnDoSubclass;
end;
end;
end;
procedure TssControlSizer.SetAllowResize(const v: boolean);
begin
if FAllowResize <> v then begin
FAllowResize := v;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetControl(const c: TControl);
var
h: TssGrabHandlePosition;
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
UnDoSubclass;
SetVisible(false);
FControl := c;
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Control := FControl;
DoSubclass;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetVisible(const v: boolean);
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Visible := v;
end;
procedure TssControlSizer.StartMoveControl(const x, y: Smallint);
begin
if FStartMovePos.X <> -1 then exit;
FStartMovePos := Point(x, y);
FParentControl := FindParent(FControl);
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
FLastSizeRect := rect(-1, -1, -1, -1);
FMoved := false;
FMoving := true;
SetCapture(TWinControl(FControl).Handle);
SetVisible(false);
if FControl.Parent <> nil then
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
end;
procedure TssControlSizer.SubclassProc(var msg: TMessage);
begin
if FAllowMove and (msg.msg = WM_LBUTTONDOWN) then begin
{$R-}
StartMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_LBUTTONUP) then begin
{$R-}
EndMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_MOUSEMOVE) then begin
{$R-}
MoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else
msg.Result := CallWindowProc(FOldWndProc,
TWinControl(FControl).Handle, Msg.Msg, Msg.wParam, Msg.lParam);
if msg.Msg = WM_DESTROY then
UndoSubclass
else if msg.Msg = WM_WINDOWPOSCHANGED then
ReSetHandles;
end;
procedure TssControlSizer.UndoSubclass;
begin
if (FControl is TWinControl) and Assigned(FNewWndProc) and
Assigned(FOldWndProc) then begin
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FOldWndProc));
FreeObjectInstance(FNewWndProc);
FNewWndProc := nil;
FOldWndProc := nil;
end;
end;
end.