{************************************************************************
*
*	Custom Controls Unit
*
*	WRITTEN BY:		Shawn Aubrey Baker (aka sab)
*
*	COMPUSERVE ID:	76450,22
*
*	CREDITS:			This code started out being based on the work of
*						Robert Norton, who uploaded a bitmap button unit to
*						Compuserve. Thanks Robert, it helped a lot. Also, the
*						code from the example unit (BITBTN.PAS) that came with
*						Turbo Pascal for Windows was a big help. Thanks Borland.
*
*	USE:				As you wish. Please send any comments and/or bug fixes
*						via mail to the above ID. IF IT DIES IT'S YOUR PROBLEM.
*
*	NOTES:			This file uses tabs = 3
*
*	THE PROBLEM:	The first time I tried this the custom bitmap buttons
*						worked fine in a TWindow but died a horrible death in
*						a TDlgWindow. This is because Windows creates the
*						actual controls instead of OWL. OWL provides little
*						(read NO) support for custom controls and assumes that
*						any control from a resource is fully created by the time
*						that OWL gets to its child window creation code. This
*						means that OWL doesn't try to create the window (good!)
*						but that it has installed set the window procedure to
*						its standard initialization proc (bad!). This procedure
*						(InitWndProc for those with the OWL source) depends on
*						having a global variable (CreationWindow) set that points
*						to the object being created. Since this variable hasn't
*						been set the routine goes off into la-la land. Also, the
*						InitResource method sets the DefaultProc pointer to nil,
*						which again causes OWL to go astray.
*
*	THE SOLUTION:	The method I've used to get around this is to override
*						the window procedure pointer in the TWndClass structure
*						to point my own procedure (InitCustom). Unfortunately,
*						the InitCustom procedure needs to get a pointer to the
*						object being initialized in order to get the real window
*						procedure out of the Instance variable. Therefore, I've
*						had to create a collection of custom controls and get
*						the pointers out of there. Again, this only applies to
*						controls from resources, so the object is added to the
*						collection in InitResource and removed from it in
*						InitCustom. It is possible to get into problems with this
*						if you Init 2 dialogs with custom controls before you
*						ExecDialog either of them. If there is a TCustom control
*						with the same ID in the two resources then there is no
*						telling which one will get picked out of the collection.
*						It's simple, DON'T DO THIS!!!
*
*						As far as the TWindow.InitResource problem goes, I simply
*						call TWindow.Init as it does and then set everything
*						except the DefaultProc pointer in the same way as
*						TWindow.InitResource does.
*
*	THE END.
*
************************************************************************}

unit	Custom;

interface

uses	WinTypes,WinProcs,WObjects,Strings;

type

		PCustom=^TCustom;
		TCustom=object(TWindow)
			constructor	Init(AParent:PWindowsObject; AnId:integer;
									ATitle:PChar; X,Y,W,H:integer);
			constructor	InitResource(AParent:PWindowsObject; AnID:word);
			procedure	SetupWindow; virtual;
			function		GetClassName:PChar; virtual;
			procedure	GetWindowClass(var AWndClass:TWndClass); virtual;
			end;

		PCustomButton=^TCustomButton;
		TCustomButton=object(TCustom)
			OwnMouse		:	boolean;		{ Is the mouse held captive?			}
			Pressed		:	boolean;		{ Is the button currently pressed?	}
			Default		:	boolean;		{ Is this the default button?			}

			constructor	Init(AParent:PWindowsObject; AnID:integer;
									AText:PChar; X,Y,W,H:integer; IsDefault:boolean);
			constructor	InitResource(AParent:PWindowsObject; AnID:integer);
			procedure	SetupWindow; virtual;

			procedure	WMMouseMove(var Msg:TMessage);
													virtual wm_First + wm_MouseMove;

			procedure	WMLButtonDown(var Msg:TMessage);
													virtual wm_First + wm_LButtonDown;
			procedure	WMLButtonUp(var Msg:TMessage);
													virtual wm_First + wm_LButtonUp;

			procedure	WMSetFocus(var Msg:TMessage);
													virtual wm_First + wm_SetFocus;
			procedure	WMKillFocus(var Msg:TMessage);
													virtual wm_First + wm_KillFocus;

			procedure	WMKeyDown(var Msg:Tmessage);
													virtual wm_First + wm_KeyDown;
			procedure	WMKeyUp(var Msg:Tmessage);
													virtual wm_First + wm_KeyUp;

			procedure	WMGetDlgCode(var Msg:Tmessage);
													virtual wm_First + wm_GetDlgCode;
			procedure	BMSetStyle(var Msg:Tmessage);
													virtual wm_First + bm_SetStyle;
			end;

		PBitButton=^TBitButton;
		TBitButton=object(TCustomButton)
			UpBits		:	HBitMap;
			FocUpBits	:	HBitMap;
			DownBits		:	HBitMap;
			UpName		:	PChar;
			FocUpName	:	PChar;
			DownName		:	PChar;
			bmWidth		:	integer;
			bmHeight		:	integer;

			constructor	Init(AParent:PWindowsObject; AnID,X,Y:integer;
									AUpName,AFocUpName,ADownName:PChar;
									IsDefault:boolean);
			constructor	InitResource(AParent:PWindowsObject; AnID:integer;
												AUpName,AFocUpName,ADownName:PChar);
			destructor	Done; virtual;
			procedure	SetupWindow; virtual;
			function		GetClassName:PChar; virtual;
			procedure	Paint(DC:HDC; var PaintInfo:TPaintStruct); virtual;
			end;

implementation

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----									TCustom Object									----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*	Name:			InitCustom
*
*	Purpose:		Called with the first message for a custom control. This
*					routine sets the window procedure to the one pointed to
*					by Instance in the Custom object. The object is stored in
*					the Customs collection by the Init/InitResource routine
*					and it is removed here. This list is only needed in order
*					to find the actual object.
*
*	Parameters:	Message	- the first message (should be wm_NCCreate)
*					WParam	- more message info
*					LParam	- even more message info
*
*	Return:		window procedure return value (depends on the message command)
*
************************************************************************}

var	Customs:PCollection;		{ collection of custom controls }
		ACustom:PWindowsObject;	{ current custom control }

function InitCustom(HWindow:HWND; Message,WParam:word; LParam:longint):
							longint; export;

var	ID:longint;

		{ finds the Custom object in the Customs collection }

		function FindID(Custom:PCustom):boolean; far;
		begin
		FindID:=Custom^.GetID = ID;
		end;

begin

{ find the Custom object, delete it from the collection }

ID:=GetWindowWord(HWindow,gww_ID);
ACustom:=Customs^.FirstThat(@FindID);
Customs^.Delete(ACustom);

{ set the window proc to the instance proc }

SetWindowLong(HWindow,gwl_WndProc,longint(ACustom^.Instance));

{ call the instance proc to handle the message }

asm
	PUSH	HWindow
	PUSH	Message
	PUSH	WParam
	PUSH	LParam.Word[2]
	PUSH	LParam.Word[0]
	MOV	AX,DS
	LES	DI,ACustom
	CALL	ES:[DI].TWindowsObject.Instance
end;

end;

{************************************************************************
*
*	Name:			TCustom.Init
*
*	Purpose:		Initializes a custom control.
*
*	Parameters:	AParent		- parent window
*					AnID			- button ID
*					ATitle		- control title
*					X,Y,W,H		- position and size
*
*	Return:		None
*
************************************************************************}

constructor TCustom.Init(AParent:PWindowsObject; AnId:integer;
									ATitle:PChar; X,Y,W,H:integer);
begin
TWindow.Init(AParent,ATitle);
Attr.Id:=AnId;
Attr.X:=X;
Attr.Y:=Y;
Attr.W:=W;
Attr.H:=H;
Attr.Style:=ws_Child or ws_Visible or ws_Group or ws_TabStop;
end;

{************************************************************************
*
*	Name:			TCustom.InitResource
*
*	Purpose:		Initializes a custom control from a resource and enables
*					data transfer.
*
*	Parameters:	AParent		- parent window
*					AnID			- button ID
*
*	Return:		None
*
************************************************************************}

constructor TCustom.InitResource(AParent:PWindowsObject; AnID:word);
begin

{ replacement code for TWindow.InitResource, needed		}
{ because the TWindow routine sets DefaultProc to nil,	}
{ wherease TWindow.Init sets it to the routine we want	}

TWindow.Init(AParent,nil);
SetFlags(wb_FromResource,true);
FillChar(Attr,SizeOf(Attr),0);
Attr.ID:=AnID;

{ must pre-register because Windows creates controls from resources }

if not Register then Fail;
EnableTransfer;

{ add it to the Customs collection so that the InitCustom proc can find it }

Customs^.Insert(@self);
end;

{************************************************************************
*
*	Name:			TCustom.SetupWindow
*
*	Purpose:		Sets up the window and gets the attributes if the window
*					is from a resource.
*
*	Parameters:	None
*
*	Return:		None
*
************************************************************************}

procedure TCustom.SetupWindow;
var	Rect:TRect;
		Pt:TPoint;
begin
TWindow.SetupWindow;

{ if it's from a resource then set the attributes }

if IsFlagSet(wb_FromResource) then
	begin

	{ get the client rect in screen co-ordinates }

	GetWindowRect(HWindow,Rect);
	Pt.X:=Rect.Left;
	Pt.Y:=Rect.Top;

	{ make the position relative to the parent window }

	ScreenToClient(GetWindowWord(HWindow,gww_HWndParent),Pt);
	Attr.X:=Pt.X;
	Attr.Y:=Pt.Y;

	{ get the client rect and set the window size }

	GetClientRect(HWindow,Rect);
	Attr.W:=Rect.Right-Rect.Left;
	Attr.H:=Rect.Bottom-Rect.Top;

	{ get the style info }

	Attr.Style:=GetWindowWord(HWindow,gwl_Style);
	Attr.ExStyle:=GetWindowWord(HWindow,gwl_ExStyle);
	end;
end;

{************************************************************************
*
*	Name:			TCustom.GetClassName
*
*	Purpose:		Abstract virtual method that gets the class name for a
*					custom control. Generates a run-time error to ensure
*					that the descendants override the method with their
*					own class name.
*
*	Parameters:	None
*
*	Return:		None
*
************************************************************************}

function TCustom.GetClassName:PChar;
begin
Abstract;
end;

{************************************************************************
*
*	Name:			TCustom.GetWindowClass
*
*	Purpose:		Sets the class info for a custom control. Overrides the
*					TPW startup procedure to use code that will find the
*					object in our "Customs" collection.
*
*	Parameters:	AWndClass - class information
*
*	Return:		None
*
************************************************************************}

procedure TCustom.GetWindowClass(var AWndClass:TWndClass);
begin
TWindow.GetWindowClass(AWndClass);

if IsFlagSet(wb_FromResource) then
	AWndClass.lpfnWndProc:=@InitCustom;
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----								TCustomButton Object								----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*	Name:			TCustomButton.Init
*
*	Purpose:		Initializes a custom button.
*
*	Parameters:	AParent		- parent window
*					AnID			- button ID
*					AText			- button text (or nil)
*					X,Y,W,H		- position and size
*					IsDefault	- default button ?
*
*	Return:		None
*
************************************************************************}

constructor	TCustomButton.Init(AParent:PWindowsObject; AnID:integer;
											AText:PChar; X,Y,W,H:integer;
											IsDefault:boolean);
begin
TCustom.Init(AParent,AnID,nil,X,Y,10,10);
if IsDefault then
	Attr.Style:=Attr.Style or bs_DefPushButton
else
	Attr.Style:=Attr.Style or bs_PushButton;
end;

{************************************************************************
*
*	Name:			TCustomButton.InitResource
*
*	Purpose:		Initializes a custom button from a resource.
*
*	Parameters:	AParent	- parent window
*					AnID		- button ID
*
*	Return:		None
*
************************************************************************}

constructor	TCustomButton.InitResource(AParent:PWindowsObject; AnID:integer);
begin
TCustom.InitResource(AParent,AnID);
DisableTransfer;
end;

{************************************************************************
*
*	Name:			TCustomButton.SetupWindow
*
*	Purpose:		Sets up the window and initializes the state variables.
*
*	Parameters:	None
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.SetupWindow;
begin
TCustom.SetupWindow;

Pressed:=false;
OwnMouse:=false;
Default:=Attr.Style and bs_DefPushButton = bs_DefPushButton;
end;

{************************************************************************
*
*	Name:			TCustomButton.WMLButtonDown
*
*	Purpose:		repaint the button in the down position when the left
*					mouse button is pressed.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMLButtonDown(var Msg:TMessage);
begin

{ if not already pressed then set state to pressed }

if not Pressed then
	begin
	if GetFocus <> hWindow then
		SetFocus(hWindow);
	Pressed:=true;
	OwnMouse:=true;
	SetCapture(hWindow);
	end;

{ trigger repaint }

InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*	Name:			TCustomButton.WMLButtonUp
*
*	Purpose:		If the left mouse button is pressed and then released
*					over the button then repaint it as unpressed and notify
*					the parent window.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMLButtonUp(var Msg:TMessage);
begin
if OwnMouse then
	begin
	ReleaseCapture;
	OwnMouse:=false;
	if Pressed then		{ trigger repaint and notify parent }
		begin
		Pressed:=false;
		InvalidateRect(hWindow,nil,false);
		PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
		end;
	end;
end;

{************************************************************************
*
*	Name:			TCustomButton.WMMouseMove
*
*	Purpose:		Repaints the button when the mouse is pressed and moves
*					into and outof the button window.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMMouseMove(var Msg:TMessage);
var	BtnRect:TRect;
		MousePt:TPoint;
begin

{ get window rectangle and mouse point }

GetClientRect(hWindow,BtnRect);
MousePt.X:=integer(Msg.lParamLo);
MousePt.Y:=integer(Msg.lParamHi);

{ if the mouse is over the button }

if PtInRect(BtnRect,MousePt) then
	begin

	{ if the mouse is moved into the button area }

	if OwnMouse and (not Pressed) then
		begin
		Pressed:=true;
		InvalidateRect(hWindow,nil,false);
		end;
	end

{ if the mouse is moved out of the button area }

else if Pressed then
	begin
	Pressed:=false;
	InvalidateRect(hWindow,nil,false);
	end;
end;

{************************************************************************
*
*	Name:			TCustomButton.WMSetFocus
*
*	Purpose:		Forces repaint if the focus is set to the button.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMSetFocus(var Msg:TMessage);
begin
InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*	Name:			TCustomButton.WMKillFocus
*
*	Purpose:		Forces repaint if the focus is taken away from the button.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMKillFocus(var Msg:TMessage);
begin
InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*	Name:			TCustomButton.WMKeyDown
*
*	Purpose:		Repaints the button in the down position if the space
*					bar is pressed on the button.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMKeyDown(var Msg:Tmessage);
begin
if (Msg.wParam = $20) and not Pressed and not OwnMouse then
	begin
	Pressed:=true;
	InvalidateRect(hWindow,nil,false);
	end;
end;

{************************************************************************
*
*	Name:			TCustomButton.WMKeyUp
*
*	Purpose:		Repaints the button in the up position and notifies the
*					parent window if the space bar is pressed on the button.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMKeyUP(var Msg:Tmessage);
begin
if (Msg.wParam = $20) and Pressed and not OwnMouse then
	begin
	Pressed:=false;
	InvalidateRect(hWindow,nil,false);
	PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
	end;
end;

{************************************************************************
*
*	Name:			TCustomButton.WMGetDlgCode
*
*	Purpose:		Gets whether or not the button is the default.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.WMGetDlgCode(var Msg:Tmessage);
begin
if Default then
	Msg.Result:=dlgc_DefPushButton
else
	Msg.Result:=dlgc_UndefPushButton;
end;

{************************************************************************
*
*	Name:			TCustomButton.BMSetStyle
*
*	Purpose:		Sets the button style to either default or not.
*
*	Parameters:	Msg - a message
*
*	Return:		None
*
************************************************************************}

procedure TCustomButton.BMSetStyle(var Msg:Tmessage);
var	OldDefault:boolean;
begin
OldDefault:=Default;
Default:=Msg.WParam = bs_DefPushButton;
if Default <> OldDefault then
	InvalidateRect(hWindow,nil,false);
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----									TBitButton Object								----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*	Name:			TBitButton.Init
*
*	Purpose:		Initializes a button.
*
*	Parameters:	AParent		- parent window
*					AnID			- button ID
*					X,Y			- position
*					IsDefault	- default button ?
*					AUpName		- name of resource for up bitmap
*					AFocUpName	- name of resource for up bitmap when focused
*					ADownName	- name of resource for down bitmap
*
*	Return:		None
*
************************************************************************}

constructor TBitButton.Init(AParent:PWindowsObject; AnID,X,Y:integer;
										AUpName,AFocUpName,ADownName:PChar;
										IsDefault:boolean);
begin
TCustomButton.Init(AParent,AnID,nil,X,Y,10,10,IsDefault);

UpName:=AUpName;
FocUpName:=AFocUpName;
DownName:=ADownName;
end;

{************************************************************************
*
*	Name:			TBitButton.InitResource
*
*	Purpose:		Initializes a button from a resource.
*
*	Parameters:	AParent		- parent window
*					AnID			- button ID
*					AUpName		- name of resource for up bitmap
*					AFocUpName	- name of resource for up bitmap when focused
*					ADownName	- name of resource for down bitmap
*
*	Return:		None
*
************************************************************************}

constructor TBitButton.InitResource(AParent:PWindowsObject; AnID:integer;
										AUpName,AFocUpName,ADownName:PChar);
begin
TCustomButton.InitResource(AParent,AnID);

UpName:=AUpName;
FocUpName:=AFocUpName;
DownName:=ADownName;
end;

{************************************************************************
*
*	Name:			TBitButton.Done
*
*	Purpose:		Destroys the button.
*
*	Parameters:	None
*
*	Return:		None
*
************************************************************************}

destructor TBitButton.Done;
begin
DeleteObject(UpBits);
DeleteObject(FocUpBits);
DeleteObject(DownBits);
TCustomButton.Done;
end;

{************************************************************************
*
*	Name:			TBitButton.SetupWindow
*
*	Purpose:		Loads the bitmaps for a button, resizes the window
*					accordingly, and initializes the state variables.
*
*	Parameters:	None
*
*	Return:		None
*
************************************************************************}

procedure TBitButton.SetupWindow;
var	bm:TBitMap;
begin
TCustomButton.SetupWindow;

{ load the bitmaps }

UpBits:=LoadBitmap(hInstance,UpName);
FocUpBits:=LoadBitmap(hInstance,FocUpName);
DownBits:=LoadBitmap(hInstance,DownName);

{ resize the window to fit the bitmaps }

GetObject(DownBits,SizeOf(bm),@bm);
MoveWindow(HWindow,Attr.X,Attr.Y,bm.bmWidth+2,bm.bmHeight+2,false);
bmWidth:=bm.bmWidth;
bmHeight:=bm.bmHeight;
end;

{************************************************************************
*
*	Name:			TBitButton.GetClassName
*
*	Purpose:		Gets the class name for a bitmap button.
*
*	Parameters:	None
*
*	Return:		pointer to the class name
*
************************************************************************}

function TBitButton.GetClassName;
begin
GetClassName:='BitButton';
end;

{************************************************************************
*
*	Name:			TBitButton.Paint
*
*	Purpose:		Paints one of the bitmaps into the window depending on
*					the current state.
*
*	Parameters:	DC				- device context to paint into
*					PaintInfo	- painting information
*
*	Return:		None
*
************************************************************************}

procedure TBitButton.Paint(DC:HDC; var PaintInfo:TPaintStruct);
var	BitsDC:HDC;
		OldBitmap:HBitMap;
		OldBrush:HBrush;
begin

{ draw the border }

if Default then
	OldBrush:=SelectObject(DC,GetStockObject(Black_Brush))
else
	OldBrush:=SelectObject(DC,GetStockObject(White_Brush));
PatBlt(DC,0,0,Attr.W,1,PatCopy);
PatBlt(DC,0,0,1,Attr.H,PatCopy);
PatBlt(DC,0,Attr.H-1,Attr.W,1,PatCopy);
PatBlt(DC,Attr.W-1,0,1,Attr.H,PatCopy);
SelectObject(DC,OldBrush);

{ draw the button }

BitsDC:=CreateCompatibleDC(DC);
if Pressed then
	OldBitmap:=SelectObject(BitsDC,DownBits)
else if GetFocus = hWindow then
	OldBitmap:=SelectObject(BitsDC,FocUpBits)
else
	OldBitmap:=SelectObject(BitsDC,UpBits);
BitBlt(DC,1,1,bmWidth,bmHeight,BitsDC,0,0,SrcCopy);
SelectObject(BitsDC,OldBitmap);
DeleteDC(BitsDC);
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----									Unit initialization							----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

begin
New(Customs,Init(40,10));
end.