Betreff:             Re: Accessing serial ports with Delphi 3???
     Datum:             Wed, 26 Aug 1998 16:52:03 +0200
       Von:             Carl Smotricz <carls@ipf.de>
     Firma:             FRA AE-FPS/FDL
     Foren:             comp.lang.pascal.delphi.misc

Patrick Echterbruch wrote:
> 
> Hi all!!
> 
> Is there a way to gain access to the serial ports under Delphi 3 ?
> 
> I need to write an application which reads data from and writes to e.g.
> COM1. I've not found any predefined components, nor were there informations
> in the Delphi online-help.
> 
> I'd appreciate you sending me a Mail directly to Echterbruch@td-service.de,
> because i don't have the time to check the newsgroups frequently.
> 
> Thanks in advance
> 
> Patrick Echterbruch

Patrick,

I've recently written a simple Delphi project which makes extensive use
of serial communications. The customer was unwilling to pay and thus the
following code was rotting away in my garbage can until I came across
your post. The comments are in German but I don't think you will have
any problem with that! :)

This program was written for and ran successfully under D1. It
(probably) uses the 16 bit comms API, but ran successfully under NT 4.0
and would probably run under W95 and W98. Also, I am guessing these APIs
are still supported under D2/D3/D4.

Essentially, Delphi is making C-like calls to the Windows API, which
offers a number of functions for sending characters, checking the number
of input characters available and reading those characters. The program
does not do much else, so for simplicity the input here is polled. An
interrupt driven implementation would be more CPU efficient but more
complicated.

The following is not demo code but an actual running program (minus the
form). I've forgotten how it works, so please try to figure it out for
yourself. If you have questions remaining, contact me at 
   'carls@ipf.de'
and I can try to help you further.

re's,

Carl

---------- snip here -----------
unit DeusMain;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, Gauges, ExtCtrls, IniFiles,
  DeusImg;

type
  TfrmMain = class(TForm)
    pnlMain: TPanel;
    Balken: TGauge;
    txtData1: TLabel;
    txtData4: TLabel;
    txtData2: TLabel;
    txtData5: TLabel;
    Timer1: TTimer;
    txtData3: TLabel;
    txtData6: TLabel;
    pnlStatus: TPanel;
    pnlStatusLabel: TPanel;
    pnlStatusText: TPanel;
    lblStatusText: TLabel;
    pbxLed: TPaintBox;
    lblTaktText: TLabel;
    lblHeaderLinks: TLabel;
    lblHeaderRechts: TLabel;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure pbxLedPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

const
  CR = #13;

{ *** FEHLER *** }
const
  FehlerAllesOK = 0;
  FehlerTafelTimeout = 1;
  FehlerTafelKaputt = 2;
  FehlerHostTimeout = 4;

type
  TFehler = class(TObject)
  private
    FStatus: Integer;
  public
    constructor Create;
    procedure displayStatus;
    procedure setTafelTimeout;
    procedure setTafelKaputt;
    procedure setTafelOK;
    procedure setHostTimeout;
    procedure setHostOK;
    property Status: Integer read FStatus;
  end;

{ *** HOST *** }
type
  THostStatus = (HostOK, OpenFehler, HostTimeout);
  THost = class(TObject)
  private
    FStatus: THostStatus;
    procedure setStatus(st: THostStatus);
  public
    property Status: THostStatus read FStatus write setStatus;
  end;

{ *** TAFEL *** }
type
  TTafelStatus = (Gepollt, TafelTimeout, TafelOK, Tafelkaputt);
  TTafel = class(TObject)
  private
    FStatus: TTafelStatus;
    procedure setStatus(st: TTafelStatus);
  public
    Spalte1, Spalte2: String[12];
    property Status: TTafelStatus read FStatus write setStatus;
    procedure setActive(active: Boolean);
    procedure setText(Sp1, Sp2: String);
  end;


var
  Host: THost;
  Tafel: TTafel;
  Fehler: TFehler;

  SettingPort: Integer;     { COMn }
  SettingSpeed: LongInt;    { Baud }
  SettingInterval: Integer; { Sekunden }
  SettingDateiname: String; { Eingabedateiname }
  SettingStation: Byte;     { Tafel-Stationsadresse }

  Takt: Integer;

  Zeit: Integer;
  CommDCB: TDCB;
  CommOffen: Boolean;

procedure SeriellZeichenAusgeben(Zeichen: char); forward;


{ --------------------------------------------------------
  Allgemeine Routinen
  -------------------------------------------------------- }


{ Das Verzeichnis des EXE-Files zurückgeben }
function ExeDir: String;
begin
  ExeDir := ExtractFilePath(Application.ExeName);
end;


{ Daten umwandeln und auf COM-Port ausgeben }
procedure GibDatenAus(var Data1, Data2: String);
var
  GewandelteDaten: String;
  j: Integer;
begin
  GewandelteDaten := Data1 + Data2;
  for j := 1 to Length(GewandelteDaten) do
    SeriellZeichenAusgeben(GewandelteDaten[j]);
end;


{ Die Daten einlesen }
procedure LiesVomHost;
label 1, 2, 3;
var
  Datei: Text;
  VollerDateiName: String;
  OK: Boolean;
  Zeile1, Zeile2: String;
begin
  OK := false;
  VollerDateiName := ExeDir + SettingDateiName;
  if not FileExists(VollerDateiName) then goto 1;
  {$I-}
  AssignFile(Datei, VollerDateiName);
  if IOResult <> 0 then goto 1;
  Reset(Datei);
  if IOResult <> 0 then goto 3;
  if Eof(Datei) then goto 1;
  Readln(Datei, Zeile1);
  if IOResult <> 0 then goto 1;
  if Eof(Datei) then goto 1;
  Readln(Datei, Zeile2);
  if IOResult <> 0 then goto 1;
  { Hier alles OK }
  OK := true;
3: { Fehler-Recovery mit Close und Delete }
  CloseFile(Datei);
  if IOResult <> 0 then goto 2;
2: { Fehler-Recovery mit Delete }
  DeleteFile(VollerDateiName);
  if IOResult <> 0 then goto 1;
1: { Fehler-Recovery ohne Close oder Delete }
  {$I+}
  if not OK then begin
    if Host.Status = HostOK then
      Host.Status := OpenFehler
    else
      Host.Status := HostTimeout;
  end else begin
    { Daten sind OK - jetzt fuer die Tafel aufbereiten }
    Tafel.setText(Zeile1, Zeile2);
    Host.Status := HostOK;
  end;
end;


{ Ein Telegramm vom seriellen Port einlesen }
function SeriellEinlesen: String;
var
  Stat: TComStat;
  NChars: Word;
  Buf: Array[0..200] of Char;
  j: Integer;
  InputStr: String;
begin
  { Versuche, Text vom Port zu bekommen }
  InputStr := '';
  GetCommError(CommDCB.ID, Stat);
  NChars := Stat.cbInQue;
  if NChars > 0 then begin
    NChars := ReadComm(CommDCB.ID, Buf, 200);
    if NChars > 0 then begin
      for j := 1 to NChars do
        InputStr := InputStr + Buf[j-1];
    end; { if }
  end; { if }
  Result := InputStr;
end;


{ Die serielle Schnittstelle oeffnen }
function SeriellOeffnen: Boolean;
const                    { from DOC\WINTYPES.INT        }
  ie_BadID    = (-1);    { Invalid or unsupported id    }
  ie_Open     = (-2);    { Device Already Open          }
  ie_NoPen    = (-3);    { Device Not Open              }
  ie_Memory   = (-4);    { Unable to allocate queues    }
  ie_Default  = (-5);    { Error in default parameters  }
  ie_Hardware = (-10);   { Hardware Not Present         }
  ie_ByteSize = (-11);   { Illegal Byte Size            }
  ie_BaudRate = (-12);   { Unsupported BaudRate         }
var
  CommStat: Integer;
  PortName:  Array[1..20] of char;  { 'COM1' + #0; }
  CommParms: Array[1..50] of char;  { 'COM1:2400,N,8,1' + #0; }
begin
  StrPCopy(@PortName, Format('COM%d', [SettingPort]));
  StrPCopy(@CommParms, Format('COM%d:%d,N,8,1', [SettingPort,
SettingSpeed]));
  { Open COM port }
  CommStat := OpenComm(@PortName, 1024, 1024);
  if CommStat < 0 then begin
    MessageDlg(
      Format('Der Port %s konnte nicht geöffnet werden. ' +
             '(Fehlerstatus: %d)' + CR + CR +
             'Bitte wählen Sie  einen anderen Port oder ' +
             'beheben Sie ggfs. das Hardware-Problem!',
             [StrPas(@PortName), CommStat]),
      mtError, [mbOK], 0);
    Result := False;
  end else begin
    CommStat := BuildCommDCB(@CommParms, CommDCB);
    if CommStat < 0 then begin
      MessageDlg(
        Format('BuildCommDCB Error; String = "%s"', [CommParms]),
        mtError, [mbOK], 0);
      Result := False;
    end;
    CommStat := SetCommState(CommDCB);
    if CommStat < 0 then begin
      MessageDlg(
        Format('SetCommState Error %d', [CommStat]),
        mtError, [mbOK], 0);
      Result := False;
    end else begin
      CommOffen := True;
      Result := True;
    end;
  end;
end; { SeriellOeffnen }


{ Schnittstelle dicht }
procedure SeriellSchliessen;
begin
  if CommDCB.ID <> $FF then
    CloseComm(CommDCB.ID);
end;


{ Ein Zeichen aufs serielle Port ausgeben }
procedure SeriellZeichenAusgeben(Zeichen: char);
var
  Stat: TComStat;
  Buf: Array[0..0] of Char;
begin
  GetCommError(CommDCB.ID, Stat);
  Buf[0] := Zeichen;
  WriteComm(CommDCB.ID, @Buf[0], 1);
end;


{ Takt 0:
  Ggw. Status auf Display ausgeben, Tafel pollen. }
procedure Takt0;
begin
  Fehler.displaystatus;
  Zeit := Zeit + 1;
  if Zeit > SettingInterval then
    Zeit := 0;
  frmMain.Balken.Progress := Zeit;
  { Pollen = Stationsadresse ausgeben mit High Bit }
  SeriellZeichenAusgeben(Char($80 + SettingStation));
  Tafel.Status := Gepollt;
end;


{ Takt 1:
  Lies Daten von der Tafel ein.
  Entweder Kurztelegramm (= OK)
  oder Fehlertelegramm
  oder nix }
procedure Takt1;
var
  Telegramm: String;
begin
  Telegramm := SeriellEinlesen;
  if Telegramm = '' then begin
    Tafel.Status := TafelTimeout;
    Fehler.setTafelTimeout;
  end else if Length(Telegramm) = 1 then begin
    (* Kurztelegramm *)
    Tafel.Status := TafelOK;
    Fehler.setTafelOK;
  end else begin
    (* Fehlertelegramm auswerten *)
    Tafel.Status := TafelKaputt;
    Fehler.setTafelKaputt;
  end;
end;


{ Takt 2:
  1. Versuch, Daten vom Host zu lesen.
  Dies passiert nur, wenn das Intervall genau fertig ist. }
procedure Takt2;
begin
  if Zeit = SettingInterval then
    LiesVomHost;
end;


{ Takt 3:
  2. Versuch, Daten vom Host zu lesen.
  Nur, wenn der 1. Versuch gescheitert war. }
procedure Takt3;
begin
  if (Zeit = SettingInterval) and (Host.Status = OpenFehler) then
    LiesVomHost;
end;


{ Takt 4:
  Dummy-Read of Antwort vom Telegramm (sofern vorhanden) }
procedure Takt4;
begin
  SeriellEinlesen;
end;


{ --------------------------------------------------------
  Routine(n) des Objekts 'Fehler'
  -------------------------------------------------------- }

constructor TFehler.Create;
begin
  inherited Create;
  FStatus := 0;
end;


procedure TFehler.displayStatus;
const
  TempStatus: Integer = 0;
begin
  if TempStatus = 0 then
    TempStatus := Fehler.Status;
  if (TempStatus and FehlerTafelTimeout) > 0 then begin
    frmMain.lblStatusText.Caption := 'Keine Verbindung zur Tafel';
    frmMain.lblStatusText.Color := clRed;
    TempStatus := TempStatus and not FehlerTafelTimeout;
  end else if (TempStatus and FehlerTafelKaputt) > 0 then begin
    frmMain.lblStatusText.Caption := 'Tafel defekt';
    frmMain.lblStatusText.Color := clRed;
    TempStatus := TempStatus and not FehlerTafelKaputt;
  end else if (TempStatus and FehlerHostTimeout) > 0 then begin
    frmMain.lblStatusText.Caption := 'Keine Host-Daten';
    frmMain.lblStatusText.Color := clRed;
    TempStatus := TempStatus and not FehlerHostTimeout;
  end else begin
    frmMain.lblStatusText.Caption := 'OK';
    frmMain.lblStatusText.Color := clLime;
  end;
end;

procedure TFehler.setTafelTimeout;
begin
  FStatus := FStatus or FehlerTafelTimeout;
end;

procedure TFehler.setTafelKaputt;
begin
  FStatus := FStatus or FehlerTafelKaputt;
end;

procedure TFehler.setTafelOK;
begin
  FStatus := FStatus and not (FehlerTafelTimeout or FehlerTafelKaputt);
end;

procedure TFehler.setHostTimeout;
begin
  FStatus := FStatus or FehlerHostTimeout;
end;

procedure TFehler.setHostOK;
begin
  FStatus := FStatus and not FehlerHostTimeout;
end;


{ --------------------------------------------------------
  Routine(n) des Objekts 'Host'
  -------------------------------------------------------- }

{ Ändert den Status des Hosts und sorgt
  dafuer, daß das Display richtig anzeigt }
procedure THost.setStatus(st: THostStatus);
begin
  if (FStatus <> st) then begin
    FStatus := st;
    (* Display richtig aufsetzen *)
    case st of
      HostTimeout: begin
        Fehler.setHostTimeout;
        Tafel.setActive(false);
      end;
      OpenFehler,
      HostOK: begin
        Fehler.setHostOK;
        Tafel.setActive(true);
      end;
    end;
  end;
end;


{ --------------------------------------------------------
  Routine(n) des Objekts 'Tafel'
  -------------------------------------------------------- }

{ Setzt den Tafeltext aktiv oder inaktiv }
procedure TTafel.setActive(active: Boolean);
var
  Farbe: TColor;
begin
  if active then begin
    Farbe := clBlack;
  end else begin
    setText('            ', '            ');
    Farbe := clGray;
  end;

  with frmMain do begin
    txtData1.Color := Farbe;
    txtData2.Color := Farbe;
    txtData3.Color := Farbe;
    txtData4.Color := Farbe;
    txtData5.Color := Farbe;
    txtData6.Color := Farbe;
  end;
end;

{ Ändert den Status der Tafel und sorgt dafuer, daß die LED umschaltet }
procedure TTafel.setStatus(st: TTafelStatus);
begin
  if (FStatus <> st) then begin
    FStatus := st;
    frmMain.pbxLed.invalidate;
  end;
end;

{ Setzt die Tafel-Texte ins Display }
procedure TTafel.setText(Sp1, Sp2: String);
var
  Telegramm: String;
  j: Integer;
begin
  Tafel.Spalte1 := Sp1;
  Tafel.Spalte2 := Sp2;
  { Daten auf Bildschirm abbilden }
  frmMain.txtData1.Caption := Copy(Sp1,2,4);
  frmMain.txtData2.Caption := Copy(Sp1,6,4);
  frmMain.txtData3.Caption := Copy(Sp1,10,4);
  frmMain.txtData4.Caption := Copy(Sp2,2,4);
  frmMain.txtData5.Caption := Copy(Sp2,6,4);
  frmMain.txtData6.Caption := Copy(Sp2,10,4);
  { Daten als Telegramm für Tafel aufbereiten }
  Telegramm := '';
  (* formatieren!! *)
  { ausgeben }
  for j := 1 to Length(Telegramm) do
    SeriellZeichenAusgeben(Telegramm[j]);
end;

{ --------------------------------------------------------
  Die folgenden Routinen haengen an Events, d.h. an
  Windows-Ereignissen. Sie stehen hier in der Reihenfolge,
  in der sie normalerweise aufgerufen werden.
  -------------------------------------------------------- }

{ Wenn die Form erzeugt wird, d.h. beim Programmstart. }
procedure TfrmMain.FormCreate(Sender: TObject);
var
  IniFile: TIniFile;
begin
  IniFile := TIniFile.Create(ChangeFileExt(Application.ExeName,
'.INI'));
  SettingPort := IniFile.ReadInteger('Comm', 'Port', 2);
  SettingSpeed := IniFile.ReadInteger('Comm', 'Speed', 9600);
  SettingStation := IniFile.ReadInteger('Comm', 'Station', 1);
  SettingInterval := IniFile.ReadInteger('Data', 'Interval', 120);
  Top := IniFile.ReadInteger('Window', 'Top', 0);
  Left := IniFile.ReadInteger('Window', 'Left', 0);
  WindowState := TWindowState(IniFile.ReadInteger('Window', 'State',
Ord(wsNORMAL)));
  SettingDateiName := IniFile.ReadString('Data', 'File', 'DATEN.DAT');
  lblHeaderLinks.Caption := IniFile.ReadString('Header', 'Links',
'TAFEL1');
  lblHeaderRechts.Caption := IniFile.ReadString('Header', 'Rechts',
'TAFEL2');
  IniFile.Free;
  CommDCB.ID := $FF;  { keine Schnittstelle aktiv }
  Balken.MaxValue := SettingInterval;
end;


{ Wenn die Form gezeigt wird }
procedure TfrmMain.FormShow(Sender: TObject);
begin
  if not SeriellOeffnen then begin
    Close;
  end;
end;


{ Dies passiert jede 1/5 Sekunde beim Tick des Timers }
procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
  Takt := (Takt + 1) mod 5;
  lblTaktText.Caption := IntToStr(Takt);
  case Takt of
  0: Takt0;
  1: Takt1;
  2: Takt2;
  3: Takt3;
  4: Takt4;
  end;
end;


{ Darstellung der LED }
procedure TfrmMain.pbxLedPaint(Sender: TObject);
  procedure {internal} KopiereBild(nach: TPaintBox; von: TImage);
  var
    bgColor: TColor;
  begin
    bgColor := von.Canvas.Pixels[0,0];
    nach.Canvas.BrushCopy(Rect(0,0,15,15), TBitmap(von.Picture.Graphic),
                          Rect(0,0,15,15), bgColor);
  end;
begin
  case Tafel.Status of
  Gepollt:      KopiereBild(frmMain.pbxLed, frmImages.imgLedAus);
  TafelTimeout: KopiereBild(frmMain.pbxLed, frmImages.imgLedRot);
  TafelOK:      KopiereBild(frmMain.pbxLed, frmImages.imgLedGruen);
  end;
end;

{ Beim Schliessen des Programms }
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
var
  IniFile: TIniFile;
begin
  Timer1.enabled := False;
  SeriellSchliessen;
  IniFile := TIniFile.Create(ChangeFileExt(Application.ExeName,
'.INI'));
  IniFile.WriteInteger('Comm', 'Port', SettingPort);
  IniFile.WriteInteger('Comm', 'Speed', SettingSpeed);
  IniFile.WriteInteger('Comm', 'Station', SettingStation);
  IniFile.WriteInteger('Data', 'Interval', SettingInterval);
  IniFile.WriteString ('Data', 'File', SettingDateiName);
  IniFile.WriteInteger('Window', 'Top', Top);
  IniFile.WriteInteger('Window', 'Left', Left);
  IniFile.WriteInteger('Window', 'State', Ord(WindowState));
  IniFile.WriteString ('Header', 'Links', lblHeaderLinks.Caption);
  IniFile.WriteString ('Header', 'Rechts', lblHeaderRechts.Caption);
  IniFile.Free;
end;

initialization
  Tafel := TTafel.Create;
  Tafel.Status := Gepollt;
  Host := THost.Create;
  Host.Status := HostOK;
  Fehler := TFehler.Create;
end.

--------------------------------
-- 
If the price is right my programming skill is yours.
But unless otherwise stated, my opinions are my own.