Category : Pascal Source Code
Archive   : TPWMI2.ZIP
Filename : MEMSTAT.PAS

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.