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

{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.