[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]
{
This program demonstrates a simple terminal emulator using
Serial Communications. Windows provides support for the
communications port so your program will be able to poll the
port and send/recieve data from a remote location.
Since this is not a program that Borland International has
developed through normal quality channels, we do not provide
technical support or establish bug lists for this demonstration
program. It is for the sole purpose of demonstrating the use
of the available functions.
}
Program Terminal;
uses WinTypes, WinProcs, WObjects, Strings;
const
idEdit = 100;
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. }
Config = 'com2:24,n,8,1';
CPort = 'com2';
{ An example of using communication port 1, 1200 baud, Even parity }
{ 7 data bits, 2 stop bits. }
{ Config = 'com1:12,e,7,2'; }
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 Error(E: Integer; C: PChar);
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure ReadChar; virtual;
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 preloaded 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 incomming in formation from the comm }
{ 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 more to many lines }
begin { have been added delete}
AtFree(0); { current line and let }
PutChar := True; { the call procedure }
end; { know to scroll up. }
end;
{ TCommWindow }
{ The CommWindow displays the incoming and out goinging text. Note }
{ that the text type by the use 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;
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;
{ 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);
end;
{ Redraw all the lines in the buffer by 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 charecter 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 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.SetUpWindow;
var
DCB: TDCB;
begin
TWindow.SetUpWindow;
SetHeight;
{ Open for Comm2 2400 Baud, No Parity, 8 Data Bits, 1 Stop Bit }
BuildCommDCB(Config, DCB);
Cid := OpenComm('COM2', 1024, 1024);
Error(Cid, 'Open');
DCB.ID := CID;
Error(SetCommState(DCB), 'Set Comm State');
WriteComm(Cid, 'ATZ'#13#10, 5); { Send a reset to Modem. }
end;
{ Call back function used only in 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 the 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 Communication Port. }
procedure TCommWindow.wmChar(var Message: TMessage);
begin
if CID <> 0 then
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;
var
Stat: TComStat;
I, Size: Integer;
C: Char;
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 used for polling. }
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.
[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]