program MemStats;

{$R MemStat.RES}

uses WObjects, WinTypes, WinProcs, Strings, Frames;

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

	PMemStatsWindow = ^TMemStatsWindow;
	TMemStatsWindow = 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;
	PctTxt:array[0..4] of Char;
	InitMem:longint;

const
	sc_About=100;
	sc_Options=101;

procedure TMemStatsApp.InitMainWindow;
begin
	MainWindow := New(PMemStatsWindow, Init(nil, 'Memory Stats'));
	InitMem:=MemAvail;
end;

function TMemStatsWindow.GetClassName: PChar;
begin
	GetClassName := 'MemStats'
end;

procedure TMemStatsWindow.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 TMemStatsWindow.SetupWindow;
var ResMenu:HMenu;
		T:longint;
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.',
							 'MemStats Stats',mb_IconExclamation or mb_OK);
		CloseWindow;
	end;
	UpdateWindow(HWindow);
	ResMenu:=GetSystemMenu(HWindow,false);
	DeleteMenu(ResMenu,sc_Restore,mf_ByCommand);
	DeleteMenu(ResMenu,sc_Maximize,mf_ByCommand);
			{This is a weird one - I couldn't gray Restore and Maximize for
			 some reason...so I deleted them. Pretty unnecessary. If someone
			 could tell me what I'm doing wrong here, could you please tell me?}
	AppendMenu(ResMenu,mf_String,0,nil);
	AppendMenu(ResMenu,mf_String,sc_About,'&About Memory Stats...');
	SendMessage(HWindow,wm_Timer,1,0);
end;

procedure TMemStatsWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var TextMetrics:TTextMetric;
		LogicFont:HFont;
		size:integer;
		wout:boolean;
begin
	with R do
	begin
		Right:=GetSystemMetrics(sm_CXIcon)+3;
		Bottom:=GetSystemMetrics(sm_CYIcon)+3;
		Left:=0;Top:=0;
	end;
	DrawBorderFrame(PaintDC,R,true);
	size:=15;
	wout:=true;
	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))<(R.right-2) then wout:=false
		else
			begin
				DeleteObject(LogicFont);
				size:=size-1;
			end;
	end;
	SetBkMode(PaintDC,Transparent);
	SetTextAlign(PaintDC,ta_Bottom);
	SetTextColor(PaintDC,RGB(0,0,0));
	GetTextMetrics(PaintDC,TextMetrics);
	TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt,StrLen(PctTxt))))/2),
		R.bottom-Round((R.bottom-TextMetrics.tmHeight-2)/2),PctTxt,StrLen(PctTxt));
	DeleteObject(LogicFont);
end;

procedure TMemStatsWindow.WMTimer(var Msg:TMessage);
var
	wFree,wSize:word;
	GDIPct,UserPct,dwInfo:longint;
	PctTxtT:array[0..4] of char;
	PctNum:string;
begin
	Str(Round(MemAvail/InitMem*100),PctNum);
	StrPCopy(PctTxtT,PctNum+'%');
	if (StrPas(PctTxtT) <> StrPas(PctTxt)) or (Msg.wParam=1) then
	begin
		StrPCopy(PctTxt,PctTxtT);
		InvalidateRect(HWindow,nil,false);
		UpdateWindow(HWindow);
	end;
end;

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

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

procedure TMemStatsWindow.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 TMemStatsWindow.About;
var Dialog:TDialog;
begin
	Dialog.Init(@Self, 'About');
	Dialog.Execute;
	Dialog.Done;
end;

var
	MemStatsApp: TMemStatsApp;

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