{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Tips & Techniques Demo Program }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}
program ModemoDemo;
{$R Modem}
uses WinTypes, WinProcs, WObjects, Strings;
type
TEditLine = array[0..50] of Char;
const
idEdit = 100;
idDial = 201;
idDialStart = 101;
idPhoneNum = 102;
idConfigure = 202;
id1200 = 101;
id2400 = 102;
id4800 = 103;
id9600 = 104;
idOdd = 105;
idEven = 106;
idNone = 107;
idComm1 = 108;
idComm2 = 109;
id1Stop = 110;
id2Stop = 111;
id7Data = 112;
id8Data = 113;
LineWidth = 80; { Width of each line displayed. }
LineHeight = 60; { Number of lines that are held in memory. }
{ The configuration string below is used to configure the modem. }
{ It is set for communication port 2, 2400 baud, No parity, 8 data }
{ bits, 1 stop bit. }
Comm : Char = '2';
Baud : Word = 24;
Parity: Char = 'n';
Stop : Char = '1';
Data : Char = '8';
DialStart: TEditLine = 'ATDT';
PhoneNumber: TEditLine = '';
type
TApp = object(TApplication)
procedure Idle; virtual;
procedure InitMainWindow; virtual;
procedure MessageLoop; virtual;
end;
PBuffer = ^TBuffer;
TBuffer = object(TCollection)
Pos: Integer;
constructor Init(AParent: PWindow);
procedure FreeItem(Item: Pointer); virtual;
function PutChar(C: Char): Boolean;
end;
PCommWindow = ^TCommWindow;
TCommWindow = object(TWindow)
Cid: Integer;
Buffer: PBuffer;
FontRec: TLogFont;
CharHeight: Integer;
constructor Init(AParent: PWindowsObject; ATitle: PChar);
destructor Done; virtual;
procedure Configure(var Message: TMessage);
virtual cm_First + idConfigure;
procedure Dial(var Message: TMessage);
virtual cm_First + idDial;
procedure Error(E: Integer; C: PChar);
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure ReadChar; virtual;
procedure SetConfigure;
procedure SetHeight;
procedure SetUpWindow; virtual;
procedure wmChar(var Message: TMessage);
virtual wm_Char;
procedure wmSize(var Message: TMessage);
virtual wm_Size;
procedure WriteChar;
end;
{ TBuffer }
{ The Buffer is used to hold each line that is displayed in the main }
{ window. The constant LineHeight determines the number of lines that }
{ are stored. The Buffer is prefilled with the LineHeight worth of }
{ lines. }
constructor TBuffer.Init(AParent: PWindow);
var
P: PChar;
I: Integer;
begin
TCollection.Init(LineHeight + 1, 10);
GetMem(P, LineWidth + 1);
P[0] := #0;
Pos := 0;
Insert(P);
for I := 1 to LineHeight do
begin
GetMem(P, LineWidth + 1);
P[0] := #0;
Insert(P);
end;
end;
procedure TBuffer.FreeItem(Item: Pointer);
begin
FreeMem(Item, LineWidth + 1);
end;
{ This procedure processes all incoming information from the com }
{ port. This procedure is called by TCommWindow.ReadChar. }
function TBuffer.PutChar(C: Char): Boolean;
var
Width: Integer;
P: PChar;
begin
PutChar := False;
Case C of
#13: Pos := 0; { if a Carriage Return. }
#10: { if a Line Feed. }
begin
GetMem(P, LineWidth + 1);
FillChar(P^, LineWidth + 1, ' ');
P[Pos] := #0;
Insert(P);
end;
#8:
if Pos > 0 then { if a Delete. }
begin
Dec(Pos);
P := At(Count - 1);
P[Pos] := ' ';
end;
#32..#128: { else handle all other }
begin { displayable characters.}
P := At(Count - 1);
Width := StrLen(P);
if Width > LineWidth then { if line is to wide }
begin { create a new line. }
Pos := 1;
GetMem(P, LineWidth + 1);
P[0] := C;
P[1] := #0;
Insert(P);
end
else { else add character }
begin { to current line. }
P[Pos] := C;
Inc(Pos);
P[Pos] := #0;
end;
end;
end;
if Count > LineHeight then { if too many lines }
begin { have been added delete}
AtFree(0); { current line and let }
PutChar := True; { the call procedure }
end; { scroll up. }
end;
{ TCommWindow }
{ The CommWindow displays the incoming and out going text. }
{ Note that the text typed by the user is displayed by }
{ being echoed back to the ReadChar procedure. So there is no need for }
{ wmChar to write a character to the screen. }
constructor TCommWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TWindow.Init(AParent, ATitle);
Attr.Style := Attr.Style or ws_VScroll;
Attr.Menu := LoadMenu(HInstance, 'Menu_1');
Scroller := New(PScroller, Init(@Self, 1, 1, 100, 100));
Buffer := New(PBuffer, Init(@Self));
end;
{ Close the Comm port and deallocate the Buffer. }
destructor TCommWindow.Done;
begin
Error(CloseComm(Cid), 'Close');
Dispose(Buffer, Done);
TWindow.Done;
end;
procedure TCommWindow.Configure(var Message: TMessage);
var
Trans: record
R1200,
R2400,
R4800,
R9600,
ROdd,
REven,
RNone,
RComm1,
RComm2,
R1Stop,
R2Stop,
R7Data,
R8Data: Word;
end;
D: TDialog;
P: PWindowsObject;
I: Integer;
begin
D.Init(@Self, 'Configure');
for I := id1200 to id8Data do
P := New(PRadioButton, InitResource(@D, I));
with Trans do
begin
R1200 := Byte(Baud = 12);
R2400 := Byte(Baud = 24);
R4800 := Byte(Baud = 48);
R9600 := Byte(Baud = 96);
ROdd := Byte(Parity = 'o');
REven := Byte(Parity = 'e');
RNone := Byte(Parity = 'n');
RComm1 := Byte(Comm = '1');
RComm2 := Byte(Comm = '2');
R1Stop := Byte(Stop = '1');
R2Stop := Byte(Stop = '2');
R7Data := Byte(Data = '7');
R8Data := Byte(Data = '8');
end;
D.TransferBuffer := @Trans;
if D.Execute = id_Ok then
begin
with Trans do
begin
Baud := (R1200 * 12) + (R2400 * 24) + (R4800 * 48) + (R9600 * 96);
if ROdd = bf_Checked then
Parity := 'o';
if REven = bf_Checked then
Parity := 'e';
if RNone = bf_Checked then
Parity := 'n';
if R1Stop = bf_Checked then
Stop := '1'
else
Stop := '2';
if RComm1 = bf_Checked then
Comm := '1'
else
Comm := '2';
if R7Data = bf_Checked then
Data := '7'
else
Data := '8';
SetConfigure;
end;
end;
D.Done;
end;
procedure TCommWindow.Dial(var Message: TMessage);
var
Trans: record
Start: TEditLine;
Phone: TEditLine;
end;
D: TDialog;
P: PWindowsObject;
begin
D.Init(@Self, 'Dial');
P := New(PEdit, InitResource(@D, idDialStart, SizeOf(TEditLine)));
P := New(PEdit, InitResource(@D, idPhoneNum, SizeOf(TEditLine)));
StrCopy(Trans.Start, DialStart);
StrCopy(Trans.Phone, PhoneNumber);
D.TransferBuffer := @Trans;
if D.Execute = id_Ok then
begin
StrCopy(DialStart, Trans.Start);
StrCopy(PhoneNumber, Trans.Phone);
StrCat(PhoneNumber, #13);
StrCat(PhoneNumber, #10);
Error(WriteComm(CId, DialStart, StrLen(DialStart)), 'Writing');
Error(WriteComm(CId, PhoneNumber, StrLen(PhoneNumber)), 'Writing');
PhoneNumber[StrLen(PhoneNumber) - 2] := #0;
end;
D.Done;
end;
{ Checks for comm errors and writes any errors. }
procedure TCommWindow.Error(E: Integer; C: PChar);
var
S: array[0..100] of Char;
begin
if E >= 0 then exit;
Str(E, S);
MessageBox(GetFocus, S, C, mb_Ok);
Halt(1);
end;
{ Redraw all the lines in the buffer using ForEach. }
procedure TCommWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
I: Integer;
Font: HFont;
procedure WriteOut(Item: PChar); far;
begin
TextOut(PaintDC, 0, CharHeight * I, Item, StrLen(Item));
inc(I);
end;
begin
I := 0;
Font := SelectObject(PaintDC, CreateFontIndirect(FontRec));
Buffer^.ForEach(@WriteOut);
DeleteObject(SelectObject(PaintDC, Font));
end;
{ Read a character from the comm port, if there is no error then call }
{ Buffer^.PutChar to add it to the buffer and write it to the screen. }
procedure TCommWindow.ReadChar;
var
Stat: TComStat;
I, Size: Integer;
C: Char;
begin
GetCommError(CID, Stat);
for I := 1 to Stat.cbInQue do
begin
Size := ReadComm(CID, @C, 1);
Error(Size, 'Read Comm');
if Size = 0 then Exit;
if C <> #0 then
begin
if Buffer^.PutChar(C) then
begin
ScrollWindow(HWindow, 0, -CharHeight, Nil, Nil);
UpDateWindow(HWindow);
end;
WriteChar;
end;
end;
end;
procedure TCommWindow.SetConfigure;
var
Config: array[0..20] of Char;
S: array[0..5] of Char;
DCB: TDCB;
begin
StrCopy(Config, 'com?:??,?,?,?');
Config[3] := Comm;
Config[8] := Parity;
Config[10] := Data;
Config[12] := Stop;
Str(Baud, S);
Config[5] := S[0];
Config[6] := S[1];
BuildCommDCB(Config, DCB);
DCB.ID := CID;
Error(SetCommState(DCB), 'Set Comm State');
end;
procedure TCommWindow.SetUpWindow;
var
DCB: TDCB;
CommString: array[0..5] of Char;
begin
TWindow.SetUpWindow;
SetHeight;
{ Open for Comm2 2400 Baud, No Parity, 8 Data Bits, 1 Stop Bit }
StrCopy(CommString, 'Com ');
CommString[3] := Comm;
Cid := OpenComm(CommString, 1024, 1024);
Error(Cid, 'Open');
SetConfigure;
WriteComm(Cid, 'ATZ'#13#10, 5); { Send a reset to Modem. }
end;
{ Call back function used only to get record structure for fixed }
{ width font. }
function GetFont(LogFont: PLogFont; TM: PTextMetric; FontType: Word;
P: PCommWindow): Integer; export;
begin
if P^.CharHeight = 0 then
begin
P^.FontRec := LogFont^;
P^.CharHeight := P^.FontRec.lfHeight;
end;
end;
{ Get a fixed width font to use in the TCommWindow. Use EnumFonts }
{ to save work of create the FontRec by hand. }
{ The TScroller of the main window is also updated know that the font }
{ height is known. }
procedure TCommWindow.SetHeight;
var
DC: HDC;
ProcInst: Pointer;
begin
DC := GetDC(HWindow);
CharHeight := 0;
ProcInst := MakeProcInstance(@GetFont, HInstance);
EnumFonts(DC, 'Courier', ProcInst, @Self);
FreeProcInstance(ProcInst);
ReleaseDC(HWindow, DC);
Scroller^.SetUnits(CharHeight, CharHeight);
Scroller^.SetRange(LineWidth, LineHeight);
Scroller^.ScrollTo(0, LineHeight);
end;
{ Write the character from the pressed key to the Comuniction Port. }
procedure TCommWindow.wmChar(var Message: TMessage);
begin
Error(WriteComm(CId, @Message.wParam, 1), 'Writing');
end;
procedure TCommWindow.wmSize(var Message: TMessage);
begin
TWindow.wmSize(Message);
Scroller^.SetRange(LineWidth, LineHeight - (Message.lParamhi div CharHeight));
end;
procedure TCommWindow.WriteChar;
var
DC: HDC;
Font: HFont;
S: PChar;
APos: Integer;
begin
APos := Buffer^.Count - 1;
S := Buffer^.AT(APos);
APos := (APos - Scroller^.YPos) * CharHeight;
if APos < 0 then exit;
if HWindow <> 0 then
begin
DC := GetDC(HWindow);
Font := SelectObject(DC, CreateFontIndirect(FontRec));
TextOut(DC, 0, APos, S, StrLen(S));
DeleteObject(SelectObject(DC, Font));
ReleaseDC(HWindow, DC);
end;
end;
{ TApp }
procedure TApp.Idle;
begin
if MainWindow <> Nil then
if MainWindow^.HWindow <> 0 then
PCommWindow(MainWindow)^.ReadChar;
end;
procedure TApp.InitMainWindow;
begin
MainWindow := New(PCommWindow, Init(Nil, 'Comm Test'));
end;
{ Add Idle loop to main message loop. }
procedure TApp.MessageLoop;
var
Message: TMsg;
begin
while True do
begin
if PeekMessage(Message, 0, 0, 0, pm_Remove) then
begin
if Message.Message = wm_Quit then
begin
Status := Message.WParam;
Exit;
end;
if not ProcessAppMsg(Message) then
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
end
else
Idle;
end;
end;
var
App: TApp;
begin
App.Init('Comm');
App.Run;
App.Done;
end.
END -- Cut Here -- cut here
(
geocities.com/~franzglaser)