{RESOURCE STATS
	by Steve Willer of Mark Data Management (Copyright 1992)
	This program is copyright, but you may use any function or whatever in
	this source. The only prohibited thing is the re-releasing of code
	edited by you, with my name still on it. If you're going to do this,
	take my name and company name out and don't re-release the docs. I don't
	want people bugging me about code I didn't write.
	This code shouldn't hurt your system, but I make no guarantees. Since
	this is freeware, you hold your own responsibility for using it and the
	problems that may arrive thus. If there are bugs or suggestions, though,
	by all means contact me.
	If there are any questions as to what's going on in the code or you have
	suggestions, by all means contact me. The info is in the docs as well as
	the 'About' box.
	Since the last revision, I have added both stats to the icon box.
	The top number is the GDI percent and the bottom is USER.}

program Resource;

{$R Resource.RES}

uses WObjects, WinTypes, WinProcs, Strings, Frames;

function GetHeapSpaces(Handle:THandle):longint; far; external 'KERNEL';
					{Undocumented function that DOES work with Win 3.1. I know there
					 is another function for this purpose that is documented, but
					 the call is very ugly.}



type
	TResourceApp = object(TApplication)
		procedure InitMainWindow; virtual;
	end;

	PResourceWindow = ^TResourceWindow;
	TResourceWindow = object(TWindow)
		function GetClassName: PChar; virtual;
		procedure SetupWindow; virtual;
		procedure GetWindowClass(var AWndClass: TWndClass); virtual;
		procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct); virtual;
		procedure WMDestroy(var Msg:TMessage); virtual wm_First+wm_Destroy;
		procedure About;
		procedure WMQueryOpen(var Msg:TMessage); virtual wm_First+wm_QueryOpen;
		procedure WMSysCommand(var Msg:TMessage); virtual wm_First+wm_SysCommand;
		procedure WMTimer(var Msg:TMessage); virtual wm_First+wm_Timer;
	end;

var
	R:TRect;
	PctTxt1:array[0..4] of Char;
  PctTxt2:array[0..4] of Char;
  size:integer;
const
	sc_About=100;
	sc_Options=101;

procedure TResourceApp.InitMainWindow;
begin
	MainWindow := New(PResourceWindow, Init(nil, 'Resource Stats'));
end;

function TResourceWindow.GetClassName: PChar;
begin
	GetClassName := 'ResourceWindow'
end;

procedure TResourceWindow.GetWindowClass(var AWndClass: TWndClass);
begin
	TWindow.GetWindowClass(AWndClass);
	AWndClass.HIcon := 0; {This is a necessary line. It tells Windows to
												 leave the iconized window blank, allowing a
												 program to draw on it.}
end;

procedure TResourceWindow.SetupWindow;
var ResMenu:HMenu;
		T:longint;
		wout:boolean;
    LogicFont:HFont;
    PaintDC:HDC;
begin
	TWindow.SetupWindow;
	if SetTimer(HWindow,20,500,nil)=0 then  {timer set for 1/2 second}
	begin
		MessageBox(HWindow,'Too many timers in use. Cannot load.',
							 'Resource Stats',mb_IconExclamation or mb_OK);
		CloseWindow;
	end;
	UpdateWindow(HWindow);
	ResMenu:=GetSystemMenu(HWindow,false);
	size:=15;
	wout:=true;
  PaintDC:=GetDC(HWindow);
	while wout do
	begin
		LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
		SelectObject(PaintDC,LogicFont);
		If Loword(GetTextExtent(PaintDC,'100%',4))<(GetSystemMetrics(sm_CXIcon)) then wout:=false
		else size:=size-1;
    DeleteObject(LogicFont);
	end;
  ReleaseDC(HWindow,PaintDC);
  if (size*2) > Round(GetSystemMetrics(sm_CYIcon)*0.45) then
  	size := Round(GetSystemMetrics(sm_CYIcon)*0.45);
{	EnableMenuItem(ResMenu,sc_Maximize,mf_ByCommand or mf_Grayed or mf_Disabled);
	EnableMenuItem(ResMenu,sc_Restore,mf_ByCommand or mf_Grayed or mf_Disabled);}
	DeleteMenu(ResMenu,sc_Restore,mf_ByCommand);
	DeleteMenu(ResMenu,sc_Maximize,mf_ByCommand);
	AppendMenu(ResMenu,mf_String,0,nil);
	AppendMenu(ResMenu,mf_String,sc_About,'&About Resource Stats...');
	SendMessage(HWindow,wm_Timer,1,0);
end;

procedure TResourceWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var TextMetrics:TTextMetric;
		OldFont,LogicFont:HFont;
    Y1,Y2:integer;
begin
	with R do
	begin
		Right:=GetSystemMetrics(sm_CXIcon)+3;
		Bottom:=GetSystemMetrics(sm_CYIcon)+3;
		Left:=0;Top:=0;
	end;
	DrawBorderFrame(PaintDC,R,true);

	LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  OldFont:=SelectObject(PaintDC,LogicFont);
	SetBkMode(PaintDC,Transparent);
	SetTextAlign(PaintDC,ta_Top);
	GetTextMetrics(PaintDC,TextMetrics);
  Y1:=Round((R.bottom-(2*size))/2)+1;
  Y2:=R.bottom-Y1-size+1;

	SetTextColor(PaintDC,RGB(0,0,0));
	TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt1,StrLen(PctTxt1))))/2),
		Y1,PctTxt1,StrLen(PctTxt1));
	SetTextColor(PaintDC,RGB(0,0,0));
	TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt2,StrLen(PctTxt2))))/2),
		Y2,PctTxt2,StrLen(PctTxt2));

  SelectObject(PaintDC,OldFont);
	DeleteObject(LogicFont);
	{You may notice that if the window gets uncovered, it doesn't immediately
	 redraw itself. The structure of this program dictated that this would be
	 an infinite loop, and it didn't seem worth it to rewrite this program,
	 considering that the timer is 500ms, anyway...}
end;

procedure TResourceWindow.WMTimer(var Msg:TMessage);
var
	wFree,wSize:word;
	GDIPct,UserPct,dwInfo:longint;
  PctTxtT1,PctTxtT2:array[0..4] of char;
	PctNum:string;
begin
	dwInfo:=GetHeapSpaces(GetModuleHandle('GDI'));
	wSize:=HiWord(dwInfo);
	wFree:=LoWord(dwInfo);
	GDIPct:=Round(wFree/wSize*100);
	Str(GDIPct,PctNum);
  PctNum:=PctNum+'%';
  StrPCopy(PctTxtT1,PctNum);

	dwInfo:=GetHeapSpaces(GetModuleHandle('User'));
	wSize:=HiWord(dwInfo);
	wFree:=LoWord(dwInfo);
	UserPct:=Round(wFree/wSize*100);
	Str(UserPct,PctNum);
  PctNum:=PctNum+'%';
  StrPCopy(PctTxtT2,PctNum);

	if (StrComp(PctTxt1,PctTxtT1)<>0) or (StrComp(PctTxt2,PctTxtT2)<>0) or
  		(Msg.wParam=1) then
	begin
		StrPCopy(PctTxt1,PctTxtT1);
    StrPCopy(PctTxt2,PctTxtT2);
		InvalidateRect(HWindow,nil,false);
		UpdateWindow(HWindow);
	end;
end;

procedure TResourceWindow.WMQueryOpen(var Msg:TMessage);
begin
	Msg.Result:=0;
end;

procedure TResourceWindow.WMDestroy(var Msg:TMessage);
begin
	KillTimer(HWindow,20);
	TWindow.WMDestroy(Msg);
end;

procedure TResourceWindow.WMSysCommand(var Msg:TMessage);
begin
	case Msg.wParam of
		sc_About:
				About  {I was thinking about adding an Options... menu item.}
		else			 {That's why this unnecessary Case command is here.}
			DefWndProc(Msg);
	end;
end;

procedure TResourceWindow.About;
var Dialog:TDialog;
begin
	Dialog.Init(@Self, 'About');
	Dialog.Execute;
	Dialog.Done;
end;

var
	ResourceApp: TResourceApp;

begin
	CmdShow:=sw_Minimize;
	ResourceApp.Init('ResourceApp');
	ResourceApp.Run;
	ResourceApp.Done;
end.