Betreff: Re: Accessing serial ports with Delphi 3???
Datum: Wed, 26 Aug 1998 16:52:03 +0200
Von: Carl Smotricz
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.
(
geocities.com/~franzglaser)