www.pudn.com > Όμ²ιΓ¨.zip > MAIN.PAS
(**********************************************************************
* *
* Modem Spy - Main Unit *
* *
* This program is supplied as is. I tried to do my best. Suggestions *
* enhancements, positive critics are most welcome. If you like this *
* stuff, just drop me a few lines on a postcard with a nice stamp *
* and send it to: *
* Dr. Martin Mohnhaupt *
* Mediterranean Shipping Company SA *
* 18 Chemin Rieu *
* CH - 1208 Geneva (Switzerland) *
* *
* Bottles of (good) wine will not be refused! *
* *
* Internet: mmohnhaupt@ping.ch *
* *
* E N J O Y !!! *
**********************************************************************)
unit Main;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Menus, About;
type
TForm1 = class(TForm)
Panel1: TPanel;
shpRing: TShape;
shpCts: TShape;
Label3: TLabel;
PopupMenu1: TPopupMenu;
Minimize: TMenuItem;
KillTheSpy: TMenuItem;
shpDsr: TShape;
Label4: TLabel;
shpDcd: TShape;
Label5: TLabel;
Label1: TLabel;
SetToCom1: TMenuItem;
SetToCom2: TMenuItem;
WhatAbout: TMenuItem;
shpRts: TShape;
Label2: TLabel;
Label6: TLabel;
shpDtr: TShape;
shpRxd: TShape;
Label7: TLabel;
shpTxd: TShape;
Label8: TLabel;
Timer: TTimer;
SetToCom3: TMenuItem;
SetToCom4: TMenuItem;
StayOnTop: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure KillTheSpyClick(Sender: TObject);
procedure MinimizeClick(Sender: TObject);
procedure SetToCom1Click(Sender: TObject);
procedure SetToCom2Click(Sender: TObject);
procedure WhatAboutClick(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure SetToCom3Click(Sender: TObject);
procedure SetToCom4Click(Sender: TObject);
procedure StayOnTopClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
FormName = 'Modem Spy';
ProgInfo = 'Modem Spy - Version 1.01- 03aug95';
{ Register offsets from the base I/O addresses }
MODEMCONTROL = 4;
LINESTATUS = 5;
MODEMSTATUS = 6;
{ Some masks... }
DCD : byte = $80; { Data Carrier Detect }
RI : byte = $40; { Ring Indicator }
DSR : byte = $20; { Data Set Ready }
CTS : byte = $10; { Clear To Send }
RxD : byte = $01; { Received Data Ready }
TxD : byte = $40; { Data Transmitter Empty }
RTS : byte = $02; { Request To Send }
DTR : byte = $01; { Data Terminal Ready }
var
Form1: TForm1;
Port : Word;
implementation
{$R *.DFM}
function PeekW( Segm, Offs : word ) : Word;
{ Read a word from a memoy location... }
begin
asm { Assembler (...I like it!) }
mov es, Segm
mov bx, Offs
mov ax, [es:bx]
mov Result, ax
end;
end;
{---------------------------------------------------------------------}
function RWPort( port : word ) : byte;
{ This function reads an I/O port and immediately writes the value back }
{ because reading the port clears some bytes. No interrupts may occur! }
begin
asm { Assembler (...I like it!) }
mov dx, port
cli
in al, dx { Read... }
out dx, al { ... rewrite. }
sti
mov Result, al
end;
end;
{---------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
{ This is done when the application creates the main form. }
var
pp : Word;
bAny: boolean;
begin
{ Initialize some items... }
Port := 0;
bAny := FALSE;
Brush.Style := bsClear;
Timer.Enabled := False; { No timer interrupts!!! }
Timer.Interval := 5; { Interval will be set to 5 msecs }
{ Test for the presence of COM ports by scanning the BDA (Bios Data Area). }
{ I do not know if it is a good method, but it works... There is just one }
{ problem: if the mouse is for instance on COM1, windows clears the Bios }
{ entry... This does not disturb since we want to spy the modem, not the }
{ little beast called a mouse! }
{ Note: instead of PeekW, we could have used the PASCAL Ptr(...) function! }
pp := PeekW($40, $0); { COM1 BDA }
if pp <> 0 then begin
SetToCom1.Enabled := TRUE;
SetToCom1.Checked := TRUE;
Caption := FormName + ' - COM1';
Port := pp;
bAny := TRUE;
end;
pp := PeekW($40, $2); { COM2 BDA }
if pp <> 0 then begin
SetToCom2.Enabled := TRUE;
if not bAny then begin
SetToCom2.Checked := TRUE;
Caption := FormName + ' - COM2';
Port := pp;
bAny := TRUE;
end;
end;
pp := PeekW($40, $4); { COM3 BDA }
if pp <> 0 then begin
SetToCom3.Enabled := TRUE;
if not bAny then begin
SetToCom3.Checked := TRUE;
Caption := FormName + ' - COM3';
Port := pp;
bAny := TRUE;
end;
end;
pp := PeekW($40, $6); { COM4 BDA }
if pp <> 0 then begin
SetToCom4.Enabled := TRUE;
if not bAny then begin
SetToCom4.Checked := TRUE;
Caption := FormName + ' - COM4';
Port := pp;
bAny := TRUE;
end;
end;
{ Now, enable timer events! }
Timer.Enabled := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.KillTheSpyClick(Sender: TObject);
{ This is done when we select Close from the popup menu }
begin
Close;
end;
{---------------------------------------------------------------------}
procedure TForm1.MinimizeClick(Sender: TObject);
{ This is done when we minimize... }
begin
Application.Minimize;
end;
{---------------------------------------------------------------------}
procedure TForm1.SetToCom1Click(Sender: TObject);
{ This is done when we select COM1 in the popup menu }
begin
SetToCom2.Checked := FALSE;
SetToCom3.Checked := FALSE;
SetToCom4.Checked := FALSE;
Port := PeekW($40, 0);
Caption := FormName + ' - COM1';
SetToCom1.Checked := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.SetToCom2Click(Sender: TObject);
{ This is done when we select COM2 in the popup menu }
begin
SetToCom1.Checked := FALSE;
SetToCom3.Checked := FALSE;
SetToCom4.Checked := FALSE;
Port := PeekW($40, 2);
Caption := FormName + ' - COM2';
SetToCom2.Checked := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.SetToCom3Click(Sender: TObject);
{ This is done when we select COM3 in the popup menu }
begin
SetToCom1.Checked := FALSE;
SetToCom2.Checked := FALSE;
SetToCom4.Checked := FALSE;
Port := PeekW($40, 4);
Caption := FormName + ' - COM3';
SetToCom3.Checked := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.SetToCom4Click(Sender: TObject);
{ This is done when we select COM4 in the popup menu }
begin
SetToCom1.Checked := FALSE;
SetToCom2.Checked := FALSE;
SetToCom3.Checked := FALSE;
Port := PeekW($40, 6);
Caption := FormName + ' - COM4';
SetToCom4.Checked := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.WhatAboutClick(Sender: TObject);
{ When we click on 'About' in the popup menu. Loading forms dynamically }
{ saves system resources! Use the autoload property of forms carefully! }
var AboutDlg : TAboutBox;
begin
AboutDlg := TAboutBox.Create(self);
Hide;
AboutDlg.pnVersion.Caption := ProgInfo;
AboutDlg.ShowModal;
AboutDlg.Free;
Show;
end;
{---------------------------------------------------------------------}
procedure TForm1.TimerTimer(Sender: TObject);
{ Each time a timer event occurs, we check the port we spy at }
var stat : byte;
begin
{ If we are sleeping, we do nothing }
if WindowState <> wsNormal then
Exit;
{ We never know! }
Timer.Enabled := FALSE;
{ Test the Modem Status Register }
stat := RWPort( Port + MODEMSTATUS );
{ Turn on/of the lamps }
if (stat and RI) = RI then
shpRing.Brush.Color := clRed
else
shpRing.Brush.Color := clBtnFace;
if (stat and CTS) = CTS then
shpCts.Brush.Color := clRed
else
shpCts.Brush.Color := clBtnFace;
if (stat and DSR) = DSR then
shpDsr.Brush.Color := clRed
else
shpDsr.Brush.Color := clBtnFace;
if (stat and DCD) = DCD then
shpDcd.Brush.Color := clRed
else
shpDcd.Brush.Color := clBtnFace;
{ Read the Modem Control Register }
stat := RWPort( Port + MODEMCONTROL );
{ Turn on/of the lamps }
if (stat and DTR) = DTR then
shpDtr.Brush.Color := clRed
else
shpDtr.Brush.Color := clBtnFace;
if (stat and RTS) = RTS then
shpRts.Brush.Color := clRed
else
shpRts.Brush.Color := clBtnFace;
{ Read the Line Status Register }
stat := RWPort( Port + LINESTATUS );
if (stat and RXD) = RXD then
shpRxd.Brush.Color := clGreen
else
shpRxd.Brush.Color := clBtnFace;
if (stat and TXD) <> TXD then
shpTxd.Brush.Color := clGreen
else
shpTxd.Brush.Color := clBtnFace;
{ Prepare for the next event }
Timer.Enabled := TRUE;
end;
{---------------------------------------------------------------------}
procedure TForm1.StayOnTopClick(Sender: TObject);
{ This is done when we toggle the StayOnTop menu item }
begin
StayOnTop.Checked := Not StayOnTop.Checked;
if StayOnTop.Checked then
FormStyle := fsStayOnTop
else
FormStyle := fsNormal;
end;
{---------------------------------------------------------------------}
end { Unit main }.