[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]

unit Sizer;

interface

uses
	Messages, WinTypes, Classes, WinProcs, Controls, Forms, SysUtils;

type ENonWindowOwner=class(Exception);

{------------------------------------------------------------------}
{--- Message Grabber ----------------------------------------------}
{------------------------------------------------------------------}
{Provides a component basis from which to trap messages sent to the form.
To override specific messages, descend from TMessageGrabber and either
add a message response method (such as WMGetMinMaxInfo), or override
the virtual method WndProc}

type TMessageGrabber = class(TComponent)
		private
			OwnerWndProc:TFarProc;
			MyWndProc:TFarProc;
			OwnerProcGrabbedQ:Boolean;
		protected
			procedure WndProc(var Msg:TMessage); virtual;
			procedure DefaultHandler(var Msg); override;
			procedure WMDestroy(var Msg:TWMDestroy); message WM_Destroy;
		public
			constructor Create(AOwner:TComponent); override;
			destructor  Destroy; override;
		end;

{------------------------------------------------------------------}
{--- Sizer --------------------------------------------------------}
{------------------------------------------------------------------}
{An example TMessageGrabber.
Traps WMGetMinMaxInfo to give a specified maximum dimensions.
Also resizes itself to give a specified Client area, regardless of
how many lines the menu bar wraps onto}

type
	TSizer = class(TMessageGrabber)
	private
		Resizing,SizeSet:boolean;
		DesiredWidth,DesiredHeight:longint;
		DeskSize:TPoint;
		MinW,MinH,FullW,FullH:longint;
		procedure SetDesiredWidth(NewWidth:longint);
		procedure SetDesiredHeight(NewHeight:longint);
	protected
		procedure WMGetMinMaxInfo(var Msg:TMessage); message WM_GetMinMaxInfo;
	public
		constructor Create(AOwner:TComponent); override;
		procedure Resize;
		procedure SetSurfaceBounds(Width,Height:longint);
	published
		property SurfaceWidth:longint read DesiredWidth write SetDesiredWidth;
		property SurfaceHeight:longint read DesiredHeight write SetDesiredHeight;
	end;

procedure Register;

implementation

{------------------------------------------------------------------}
{--- Message Grabber ----------------------------------------------}
{------------------------------------------------------------------}

{Create:
Override the WndProc of the owner window.
Note that it will be a very bad idea to have several MessageGrabber
components active at the same time, unless they are added and removed
carefully in order}

constructor TMessageGrabber.Create(AOwner:TComponent);
begin
if not(AOwner is TWinControl) then
	raise ENonWindowOwner.Create('Owner must be a windowed control');
inherited Create(AOwner);
OwnerWndProc:=TFarProc(GetWindowLong((Owner as TWinControl).Handle,gwl_WndProc));
MyWndProc:=MakeObjectInstance(WndProc);
SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(MyWndProc));
OwnerProcGrabbedQ:=True;
end;

{Destroy:
Removes the overriding window handler}

destructor TMessageGrabber.Destroy;
begin
if OwnerProcGrabbedQ then
	SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(OwnerWndProc));
FreeObjectInstance(MyWndProc);
inherited Destroy;
end;

{WMDestroy:
If WM_Destroy is sent to the owner, then when we get around to calling
the Destroy method here, Owner will no longer be valid. So, there are
two cases: Destroy is called without WMDestroy (ie component is removed
at design-time) and WMDestroy is called first (ie owner is about to be
destroyed)}

procedure TMessageGrabber.WMDestroy(var Msg:TWMDestroy);
begin
SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(OwnerWndProc));
OwnerProcGrabbedQ:=False;
end;

{WndProc:
For windowed controls, standard message handling is:
the message is sent to WndProc, which calls Dispatch.
Only windows controls have a WndProc. But Dispatch is a method
of TObject, used for dispatching all message-based methods, not
just Windows ones. This WndProc mimics that of a windowed control}

procedure TMessageGrabber.WndProc(var Msg:TMessage);
begin
Dispatch(Msg);
end;

{DefaultHandler:
The Dispatch method will attempt to dispatch the method, and failing
will call DefaultHandler. If a message-response method calls
its inherited method, where the inherited method is undefined, the
message is also sent to the DefaultHandler.
For a TMessageGrabber, DefaultHandler should pass any unhandled
messages back to the owner}

procedure TMessageGrabber.DefaultHandler(var Msg);
begin
with TMessage(Msg) do
	Result:=CallWindowProc(OwnerWndProc,(Owner as TWinControl).Handle,Msg,wParam,lParam);
end;

{------------------------------------------------------------------}
{--- Sizer --------------------------------------------------------}
{------------------------------------------------------------------}

constructor TSizer.Create(AOwner:TComponent);
var DeskRect:TRect;
begin
SizeSet:=false;
inherited Create(AOwner);
with Owner as TControl do
	begin
	SetSurfaceBounds(ClientWidth,ClientHeight);
	FullW:=Width;
	FullH:=Height;
	end;
Winprocs.GetClientRect(GetDesktopWindow,DeskRect);
DeskSize.X:=DeskRect.Right-DeskRect.Left;
DeskSize.Y:=DeskRect.Bottom-DeskRect.Top;
SizeSet:=true;
end;

procedure TSizer.SetSurfaceBounds(Width,Height:longint);
begin
DesiredWidth:=Width;
DesiredHeight:=Height;
with Owner as TForm do
	begin
	HorzScrollBar.Range:=DesiredWidth;
	VertScrollBar.Range:=DesiredHeight;
	end;
end;

procedure TSizer.Resize;
	procedure ShiftBounds(OldL,MaxW,Size:longint; var NewL,NewW:longint);
	begin
	if OldL>0 then begin
		NewL:=Size-NewW;
		if NewL<0 then begin
			NewW:=NewW+NewL; NewL:=0; end; end;
	end;
var Desk:TRect;
		MaxW,MaxH,OldW,OldH,NewL,NewT,NewW,NewH:longint;
begin
Resizing:=true;
NewW:=0;   NewH:=0;
with Owner as TControl do
	begin

repeat
	MaxW:=DeskSize.X-Left;
	OldW:=NewW;
	NewL:=Left;
	NewW:=Width+(DesiredWidth-ClientWidth);
	if NewW<MinW then NewW:=MinW;
	if NewW>MaxW then ShiftBounds(Left,MaxW,DeskSize.X,NewL,NewW);

	repeat
		MaxH:=DeskSize.Y-Top;
		OldH:=NewH;
		NewT:=Top;
		NewH:=Height+(DesiredHeight-ClientHeight);
		if NewH<MinH then NewH:=MinH;
		if NewH>MaxH then ShiftBounds(Top,MaxH,DeskSize.Y,NewT,NewH);

		SetBounds(NewL,NewT,NewW,NewH);

	until OldH=NewH;
until OldW=NewW;

FullW:=DesiredWidth+Width-ClientWidth;
FullH:=DesiredHeight+Height-ClientHeight;
if FullW<MinW then FullW:=MinW;
if FullH<MinH then FullH:=MinH;

Resizing:=false;
end;
end;

procedure TSizer.WMGetMinMaxInfo(var Msg:TMessage);
begin
with PMinMaxInfo(Msg.lParam)^ do
	begin
	if (not SizeSet) then
		begin
		MinW:=ptMinTrackSize.X;
		MinH:=ptMinTrackSize.Y;
		end
	else if (not Resizing) then
		begin
		ptMaxTrackSize.X:=FullW;
		ptMaxTrackSize.Y:=FullH;
		end;
	end;
end;

procedure TSizer.SetDesiredWidth(NewWidth:longint);
begin
SetSurfaceBounds(NewWidth,DesiredHeight);
Resize;
end;

procedure TSizer.SetDesiredHeight(NewHeight:longint);
begin
SetSurfaceBounds(DesiredWidth,NewHeight);
Resize;
end;

procedure Register;
begin
RegisterComponents('Additional', [TSizer]);
end;

end.

[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]