///////////////
//
// (P) Eagle.Yin
// Serial port communication unit based on timers
//
// 1999/10/02 Mainframe was finished
// 1999/10/03 Add routine 'Get_Port_Config' for debug
// Add Input-Time-Out processing code
// 1999/10/07 Add error checking when read and write serial port
// Add routine 'Set_Port_TimeOut' and delete 'tmOut' parameters in 'Open_Port'
// Add routine 'Port_Error_Str' to get text description of port error
//
{---$define debugall}
{---$define debug}
const
InBufferSize= 1024; // size of input buffer
type
TInBuffer= array[0..InBufferSize-1] of byte; // input buffer
type
TReader = procedure( len:integer; var buf:TInBuffer ) of object; // data reader procedure
TWatcher = procedure( erCode:integer ) of object; // port exception watcher
type
TSerialPort = class( TObject )
private
hReader : TReader; // handle of data reader
hWatcher : TWatcher; // handle of watcher
tmReader : TTimer; // port monitor
tmOutCnt,
tmOutVal : integer; // time out value, tmOut = TIME_OUT(ms)/tmInterval(ms)
DataInFlag: boolean; // data flow in flag
procedure Monitor( Sender:TObject );
protected
hPort : THandle; // handle of serial port
public
procedure Set_Port_TimeOut( tmOut:integer );
function Open_Port( PortName:string; BaudRate, ByteSize, StopBits, Parity:integer ):integer;
procedure Close_Port;
function WriteData( num:integer; var buf ):integer;
function Get_Port_Config( var BaudRate, ByteSize, StopBits, Parity:integer ):boolean;
implementation
uses
SysUtils, Dialogs;
//--------------------------------------------------------------------------------------------------
var
Err_Table : array[0..8] of string = ( // port error message table
'', // no error
'打开串行口失败',
'获取串行口状态失败',
'设置串行口状态失败',
'获取串行口超时失败',
'设置串行口超时失败',
'串行口无数据输入',
'读串行口错误',
'写串行口错误'
); // Error string table
function Port_Error_Str( eCode:integer ):string;
//
// This function return text description for port errors
// eCode : Port error code
// result: Text description for port error
//
begin
if ( eCode>=0 ) and ( eCode<=8 ) then
result := Err_Table[eCode] + '(' + inttostr( eCode ) + ')'
else
result := '未知串行口错误(' + inttostr( eCode ) + ')';
end;
//--------------------------------------------------------------------------------------------------
var
buf : TInBuffer; // input buffer for monitor
procedure TSerialPort.Monitor( Sender:TObject );
//
// This procedure is the 'OnTimer' event handler of 'tmReader', it reads data from serial port and
// call 'hReader' if necessary, it also counts timeouts, if timeout occured, it will call the error
// handler 'hWatcher'
//
var
eCode : dword;
cStat : COMSTAT;
numRead : dword;
begin
// manipulate serial port
eCode := 0;
ClearCommError( hPort, eCode, @cStat );
repeat
numRead :=0;
if not ReadFile( hPort, buf, sizeof( buf ), numRead, nil ) then
begin
if Assigned( hWatcher ) then // call read-error handler
hWatcher( E_READ );
exit;
end;{ if }
// count timeout counter
DataInFlag := numRead >0; // set data flow in flag
if DataInFlag then // reset time out counter if data in
tmOutCnt := 0;
inc( tmOutCnt );
if tmOutCnt>=tmOutVal then // timeout occured
begin
tmOutCnt := 0; // reset time out counter
if Assigned( hWatcher ) then
hWatcher( E_TIMEOUT );
end;{ if }
// pass data to reader
if Assigned( hReader ) then
hReader( numRead, buf );
until ( numRead<sizeof( buf ) );
end;
//--------------------------------------------------------------------------------------------------
procedure TSerialPort.Set_Port_TimeOut( tmOut:integer );
//
// This procedure set port timeout value and reset the timeout counter
// tmOut : Port timeout value, in milliseconds
//
begin
tmOutVal := tmOut div tmInterval;
tmOutCnt := 0;
end;
function TSerialPort.Open_Port( PortName:string; BaudRate, ByteSize, StopBits, Parity:integer ):integer;
//
// Open and config serial port and activate the monitor timer
//
function OpenPort:integer;
begin
hPort := INVALID_HANDLE_VALUE; // init port handle
hPort := CreateFile( pchar( PortName ), // port name
GENERIC_READ or GENERIC_WRITE, // access mode
0, // share mode
nil, // security attributes
OPEN_EXISTING, // how to create
0, // file attributes
0 ); // template file
if hPort = INVALID_HANDLE_VALUE then
result := E_OPEN
else
result := E_NO_ERROR;
{$ifdef debug}
if result<>E_NO_ERROR then
ShowMessage( 'Can not open port:' + PortName );
{$endif}
end;
function ConfigPort:integer;
var
commDCB : DCB;
commTMO : TCOMMTIMEOUTS;
begin
if not GetCommState( hPort, CommDCB ) then // can't get port state
begin
result := E_GET_STATE;
CloseHandle( hPort );
hPort := INVALID_HANDLE_VALUE;
{$ifdef debug}
ShowMessage( 'Can not get port state:' + PortName );
{$endif}
exit;
end;{ if }
commDCB.BaudRate := BaudRate; // setup port device control block
commDCB.ByteSize := ByteSize;
commDCB.StopBits := StopBits;
commDCB.Parity := Parity;
if not SetCommState( hPort, commDCB ) then // can't set port state
begin
result := E_SET_STATE;
CloseHandle( hPort );
hPort := INVALID_HANDLE_VALUE;
{$ifdef debug}
ShowMessage( 'Can not set port state:' + PortName );
{$endif}
exit;
end;{ if }
if not GetCommTimeOuts( hPort, commTMO ) then // can't get port time outs
begin
result := E_GET_TMO;
CloseHandle( hPort );
hPort := INVALID_HANDLE_VALUE;
{$ifdef debug}
ShowMessage( 'Can not get port timeouts:' + PortName );
{$endif}
exit;
end;{ if }
with commTMO do // setup port time outs
begin
ReadIntervalTimeOut:=MAXDWORD;
ReadTotalTimeOutMultiplier:=0;
ReadTotalTimeOutConstant:=0;
end;{ with }
if not SetCommTimeOuts( hPort, commTMO ) then // can't set port time outs
begin
result := E_SET_TMO;
CloseHandle( hPort );
hPort := INVALID_HANDLE_VALUE;
{$ifdef debug}
ShowMessage( 'Can not set port timeouts:' + PortName );
{$endif}
exit;
end;{ if }
result := E_NO_ERROR; // default result
end;
begin
result := OpenPort; // open port
if result<>E_NO_ERROR then
exit;
result := ConfigPort; // config port
if result<>E_NO_ERROR then
exit;
procedure TSerialPort.Close_Port;
//
// Close port and deactivate the monitor timer
//
begin
if hPort<>INVALID_HANDLE_VALUE then
begin
tmReader.Enabled := False; // disable monitor timer
PurgeComm( hPort, PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR + PURGE_RXCLEAR );
CloseHandle( hPort ); // close port
hPort := INVALID_HANDLE_VALUE;
end;{ if }
end;
function TSerialPort.WriteData( num:integer; var buf ):integer;
var
eCode : dword;
cStat : COMSTAT;
begin
eCode := 0;
ClearCommError( hPort, eCode, @cStat );
result := 0;
if not WriteFile( hPort, buf,num, dword( result ), nil ) then
begin
if Assigned( hWatcher ) then // call write error handler
hWatcher( E_WRITE );
end;{ if }
end;
function TSerialPort.Get_Port_Config( var BaudRate, ByteSize, StopBits, Parity:integer ):boolean;
//
// Get current port configuration
//
var
commDCB : DCB;
begin
result := ( hPort<>INVALID_HANDLE_VALUE );
if result then
begin
result := GetCommState( hPort, commDCB );
if result then
begin
BaudRate := commDCB.BaudRate;
ByteSize := commDCB.ByteSize;
StopBits := commDCB.StopBits;
Parity := commDCB.Parity;
end;{ if }
end;{ if }
end;
//--------------------------------------------------------------------------------------------------
constructor TSerialPort.Create( dReader:TReader; dWatcher:TWatcher );
begin
inherited Create;