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

 
Output of file : DISKD.PAS contained in archive : TPWMI2.ZIP
program DiskD;

{$R MemStat.RES}

uses WObjects, WinTypes, WinProcs, Strings, WinDOS, Frames;

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

PDiskDWindow = ^TDiskDWindow;
TDiskDWindow = 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;

const
sc_About=100;
sc_Options=101;

procedure TDiskDApp.InitMainWindow;
begin
MainWindow := New(PDiskDWindow, Init(nil, 'Space on D:'));
end;

function TDiskDWindow.GetClassName: PChar;
begin
GetClassName := 'DiskD'
end;

procedure TDiskDWindow.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 TDiskDWindow.SetupWindow;
var ResMenu:HMenu;
T:longint;
begin
TWindow.SetupWindow;
if SetTimer(HWindow,20,5000,nil)=0 then {timer set for 1/2 second}
begin
MessageBox(HWindow,'Too many timers in use. Cannot load.',
'DiskD 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);
{ AppendMenu(ResMenu,mf_String,0,nil);
AppendMenu(ResMenu,mf_String,sc_About,'&About Memory Stats...');}
SendMessage(HWindow,wm_Timer,1,0);
end;

procedure TDiskDWindow.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 TDiskDWindow.WMTimer(var Msg:TMessage);
var
wFree,wSize:word;
GDIPct,UserPct,dwInfo:longint;
PctTxtT:array[0..4] of char;
PctNum:string;
begin
Str(Round(DiskFree(4)/DiskSize(4)*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 TDiskDWindow.WMQueryOpen(var Msg:TMessage);
begin
Msg.Result:=0;
end;

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

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

var
DiskDApp: TDiskDApp;

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


  3 Responses to “Category : Pascal Source Code
Archive   : TPWMI2.ZIP
Filename : DISKD.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/