{************************************************}
{                                                }
{   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