Компонент для последовательного устройства (TRS232)

=== Компонент для последовательного устройства (TRS232) ===
Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.
В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.
// ----------------------------------------------------------------------
// | RS232 - Basic Driver for the RS232 port 1.0 |
// ----------------------------------------------------------------------
// | © 1997 by Marco Cocco |
// | © 1998 by enhanced by Angerer Bernhard |
// ----------------------------------------------------------------------
unit uRS232;
interface
uses
 Windows, Messages, SysUtils, Classes, Forms,
 ExtCtrls; // TTimer
////////////////////////////////////////////////////////////////////////////////
type
 TReceiveDataEvent = procedure(Sender: TObject; Msg, lParam, wParam:longint) of object;
 // COM Port Baud Rates
 TComPortBaudRate = ( br110, br300, br600, br1200, br2400, br4800,
 br9600, br14400, br19200, br38400, br56000,
 br57600, br115200 );
 // COM Port Numbers
 TComPortNumber = ( pnCOM1, pnCOM2, pnCOM3, pnCOM4 );
 // COM Port Data bits
 TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS );
 // COM Port Stop bits
 TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS );
 // COM Port Parity
 TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE );
 // COM Port Hardware Handshaking
 TComPortHwHandshaking = ( hhNONE, hhRTSCTS );
 // COM Port Software Handshaing
 TComPortSwHandshaking = ( shNONE, shXONXOFF );
 TCommPortDriver = class(TComponent)
 private
 hTimer: TTimer;
 FActive: boolean;
 procedure SetActive(const Value: boolean);
 protected
 FComPortHandle : THANDLE; // COM Port Device Handle
 FComPort : TComPortNumber; // COM Port to use (1..4)
 FComPortBaudRate : TComPortBaudRate; // COM Port speed (brXXXX)
 FComPortDataBits : TComPortDataBits; // Data bits size (5..8)
 FComPortStopBits : TComPortStopBits; // How many stop bits to use
 // (1,1.5,2)
 FComPortParity : TComPortParity; // Type of parity to use
 // (none,odd,even,mark,space)
 FComPortHwHandshaking : TComPortHwHandshaking; // Type of hw
 // handshaking to use
 FComPortSwHandshaking : TComPortSwHandshaking; // Type of sw
 // handshaking to use
 FComPortInBufSize : word; // Size of the input buffer
 FComPortOutBufSize : word; // Size of the output buffer
 FComPortReceiveData : TReceiveDataEvent;
 FComPortPollingDelay : word; // ms of delay between COM port pollings
 FTimeOut : integer; // sec until timeout
 FTempInBuffer : pointer;
 procedure SetComPort( Value: TComPortNumber );
 procedure SetComPortBaudRate( Value: TComPortBaudRate );
 procedure SetComPortDataBits( Value: TComPortDataBits );
 procedure SetComPortStopBits( Value: TComPortStopBits );
 procedure SetComPortParity( Value: TComPortParity );
 procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking );
 procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking );
 procedure SetComPortInBufSize( Value: word );
 procedure SetComPortOutBufSize( Value: word );
 procedure SetComPortPollingDelay( Value: word );
 procedure ApplyCOMSettings;
 procedure TimerEvent(Sender: TObject); virtual;
 public
 constructor Create( AOwner: TComponent ); override;
 destructor Destroy; override;
 function Connect: boolean; //override;
 function Disconnect: boolean; //override;
 function Connected: boolean;
 function SendData( DataPtr: pointer; DataSize: integer ): boolean;
 function SendString( aStr: string ): boolean; 
 // Event to raise when there is data available (input buffer has data)
 property OnReceiveData: TReceiveDataEvent read FComPortReceiveData
 write FComPortReceiveData;
 published
 // Which COM Port to use
 property ComPort: TComPortNumber read FComPort write SetComPort
 default pnCOM2;
 // COM Port speed (bauds)
 property ComPortSpeed: TComPortBaudRate read FComPortBaudRate
 write SetComPortBaudRate default br9600;
 // Data bits to used (5..8, for the 8250 the use of 5 data bits with 2 stop
 // bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5
 // stop bits)
 property ComPortDataBits: TComPortDataBits read FComPortDataBits
 write SetComPortDataBits default db8BITS;
 // Stop bits to use (1, 1.5, 2)
 property ComPortStopBits: TComPortStopBits read FComPortStopBits
 write SetComPortStopBits default sb1BITS;
 // Parity Type to use (none,odd,even,mark,space)
 property ComPortParity: TComPortParity read FComPortParity
 write SetComPortParity default ptNONE;
 // Hardware Handshaking Type to use:
 // cdNONE no handshaking
 // cdCTSRTS both cdCTS and cdRTS apply (This is the more common method)
 property ComPortHwHandshaking: TComPortHwHandshaking
 read FComPortHwHandshaking write SetComPortHwHandshaking default hhNONE;
 // Software Handshaking Type to use:
 // cdNONE no handshaking
 // cdXONXOFF XON/XOFF handshaking
 property ComPortSwHandshaking: TComPortSwHandshaking
 read FComPortSwHandshaking write SetComPortSwHandshaking default shNONE;
 // Input Buffer size
 property ComPortInBufSize: word read FComPortInBufSize
 write SetComPortInBufSize default 2048;
 // Output Buffer size
 property ComPortOutBufSize: word read FComPortOutBufSize
 write SetComPortOutBufSize default 2048;
 // ms of delay between COM port pollings
 property ComPortPollingDelay: word read FComPortPollingDelay
 write SetComPortPollingDelay default 100;
 property TimeOut: integer read FTimeOut write FTimeOut default 30;
 property Active: boolean read FActive write SetActive default false;
 end;
 TRS232 = class(TCommPortDriver)
 protected
 public
 // new comm parameters are set
 constructor Create( AOwner: TComponent ); override;
 // ReadStrings reads direct from the comm-buffer and waits for
 // more characters and handles the timeout
 function ReadString(var aResStr: string; aCount: word ): boolean;
 published
 end;
procedure Register;
implementation
procedure Register;
begin
 RegisterComponents('Additional', [TRS232]);
end;
constructor TCommPortDriver.Create( AOwner: TComponent );
begin
 inherited Create( AOwner );
 // Initialize to default values
 FComPortHandle := 0; // Not connected
 FComPort := pnCOM2; // COM 2
 FComPortBaudRate := br9600; // 9600 bauds
 FComPortDataBits := db8BITS; // 8 data bits
 FComPortStopBits := sb1BITS; // 1 stop bit
 FComPortParity := ptNONE; // no parity
 FComPortHwHandshaking := hhNONE; // no hardware handshaking
 FComPortSwHandshaking := shNONE; // no software handshaking
 FComPortInBufSize := 2048; // input buffer of 512 bytes
 FComPortOutBufSize := 2048; // output buffer of 512 bytes
 FComPortReceiveData := nil; // no data handler
 FTimeOut := 30; // sec until timeout
 FComPortPollingDelay := 500;
 GetMem( FTempInBuffer, FComPortInBufSize ); // Temporary buffer
 // for received data
 // Timer for teaching and messages
 hTimer := TTimer.Create(Self);
 hTimer.Enabled := false;
 hTimer.Interval := 500;
 hTimer.OnTimer := TimerEvent;
 if ComponentState = [csDesigning] then
 EXIT;
 if FActive then
 hTimer.Enabled := true; // start the timer only at application start
end;
destructor TCommPortDriver.Destroy;
begin
 // Be sure to release the COM device
 Disconnect;
 // Free the temporary buffer
 FreeMem( FTempInBuffer, FComPortInBufSize );
 // Destroy the timer's window
 inherited Destroy;
end;
procedure TCommPortDriver.SetComPort( Value: TComPortNumber );
begin
 // Be sure we are not using any COM port
 if Connected then
 exit;
 // Change COM port
 FComPort := Value;
end;
procedure TCommPortDriver.SetComPortBaudRate( Value: TComPortBaudRate );
begin
 // Set new COM speed
 FComPortBaudRate := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortDataBits( Value: TComPortDataBits );
begin
 // Set new data bits
 FComPortDataBits := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortStopBits( Value: TComPortStopBits );
begin
 // Set new stop bits
 FComPortStopBits := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortParity( Value: TComPortParity );
begin
 // Set new parity
 FComPortParity := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortHwHandshaking(Value: TComPortHwHandshaking);
begin
 // Set new hardware handshaking
 FComPortHwHandshaking := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortSwHandshaking(Value: TComPortSwHandshaking);
begin
 // Set new software handshaking
 FComPortSwHandshaking := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortInBufSize( Value: word );
begin
 // Free the temporary input buffer
 FreeMem( FTempInBuffer, FComPortInBufSize );
 // Set new input buffer size
 FComPortInBufSize := Value;
 // Allocate the temporary input buffer
 GetMem( FTempInBuffer, FComPortInBufSize );
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortOutBufSize( Value: word );
begin
 // Set new output buffer size
 FComPortOutBufSize := Value;
 // Apply changes
 if Connected then
 ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortPollingDelay( Value: word );
begin
 FComPortPollingDelay := Value;
 hTimer.Interval := Value;
end;
const
 Win32BaudRates: array[br110..br115200] of DWORD =
 ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600,
 CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200 );
const
 dcb_Binary = $00000001;
 dcb_ParityCheck = $00000002;
 dcb_OutxCtsFlow = $00000004;
 dcb_OutxDsrFlow = $00000008;
 dcb_DtrControlMask = $00000030;
 dcb_DtrControlDisable = $00000000;
 dcb_DtrControlEnable = $00000010;
 dcb_DtrControlHandshake = $00000020;
 dcb_DsrSensivity = $00000040;
 dcb_TXContinueOnXoff = $00000080;
 dcb_OutX = $00000100;
 dcb_InX = $00000200;
 dcb_ErrorChar = $00000400;
 dcb_NullStrip = $00000800;
 dcb_RtsControlMask = $00003000;
 dcb_RtsControlDisable = $00000000;
 dcb_RtsControlEnable = $00001000;
 dcb_RtsControlHandshake = $00002000;
 dcb_RtsControlToggle = $00003000;
 dcb_AbortOnError = $00004000;
 dcb_Reserveds = $FFFF8000;
// Apply COM settings.
procedure TCommPortDriver.ApplyCOMSettings;
var dcb: TDCB;
begin
 // Do nothing if not connected
 if not Connected then
 exit;
 // Clear all
 fillchar( dcb, sizeof(dcb), 0 );
 // Setup dcb (Device Control Block) fields
 dcb.DCBLength := sizeof(dcb); // dcb structure size
 dcb.BaudRate := Win32BaudRates[ FComPortBaudRate ]; // baud rate to use
 dcb.Flags := dcb_Binary or // Set fBinary: Win32 does not support non
 // binary mode transfers
 // (also disable EOF check)
 dcb_RtsControlEnable; // Enables the RTS line when the device
 // is opened and leaves it on
// dcb_DtrControlEnable; // Enables the DTR line when the device
 // is opened and leaves it on
 case FComPortHwHandshaking of // Type of hw handshaking to use
 hhNONE:; // No hardware handshaking
 hhRTSCTS: // RTS/CTS (request-to-send/clear-to-send) hardware handshaking
 dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
 end;
 case FComPortSwHandshaking of // Type of sw handshaking to use
 shNONE:; // No software handshaking
 shXONXOFF: // XON/XOFF handshaking
 dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
 end;
 dcb.XONLim := FComPortInBufSize div 4; // Specifies the minimum number
 // of bytes allowed
 // in the input buffer before the
 // XON character is sent
 dcb.XOFFLim := 1; // Specifies the maximum number of bytes allowed in the
 // input buffer before the XOFF character is sent.
 // The maximum number of bytes allowed is calculated by
 // subtracting this value from the size, in bytes,
 // of the input buffer
 dcb.ByteSize := 5 + ord(FComPortDataBits); // how many data bits to use
 dcb.Parity := ord(FComPortParity); // type of parity to use
 dcb.StopBits := ord(FComPortStopbits); // how many stop bits to use
 dcb.XONChar := #17; // XON ASCII char
 dcb.XOFFChar := #19; // XOFF ASCII char
 SetCommState( FComPortHandle, dcb );
 // Setup buffers size
 SetupComm( FComPortHandle, FComPortInBufSize, FComPortOutBufSize );
end;
function TCommPortDriver.Connect: boolean;
var comName: array[0..4] of char;
 tms: TCOMMTIMEOUTS;
begin
 // Do nothing if already connected
 Result := Connected;
 if Result then exit;
 // Open the COM port
 StrPCopy( comName, 'COM' );
 comName[3] := chr( ord('1') + ord(FComPort) );
 comName[4] := #0;
 FComPortHandle := CreateFile(
 comName,
 GENERIC_READ or GENERIC_WRITE,
 0, // Not shared
 nil, // No security attributes
 OPEN_EXISTING,
 FILE_ATTRIBUTE_NORMAL,
 0 // No template
 ) ;
 Result := Connected;
 if not Result then exit;
 // Apply settings
 ApplyCOMSettings;
 // Setup timeouts: we disable timeouts because we are polling the com port!
 tms.ReadIntervalTimeout := 1; // Specifies the maximum time, in milliseconds,
 // allowed to elapse between the arrival of two
 // characters on the communications line
 tms.ReadTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
 // milliseconds, used to calculate
 // the total time-out period
 // for read operations.
 tms.ReadTotalTimeoutConstant := 1; // Specifies the constant, in milliseconds,
 // used to calculate the total time-out
 // period for read operations.
 tms.WriteTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
 // milliseconds, used to calculate
 // the total time-out period
 // for write operations.
 tms.WriteTotalTimeoutConstant := 0; // Specifies the constant, in
 // milliseconds, used to calculate
 // the total time-out period
 // for write operations.
 SetCommTimeOuts( FComPortHandle, tms );
 Sleep(1000); // to avoid timing problems, wait until the Comm-Port is opened
end;
function TCommPortDriver.Disconnect: boolean;
begin
 Result:=false;
 if Connected then
 begin
 CloseHandle( FComPortHandle );
 FComPortHandle := 0;
 end;
 Result := true;
end;
function TCommPortDriver.Connected: boolean;
begin
 Result := FComPortHandle > 0;
end;
function TCommPortDriver.SendData(DataPtr: pointer; DataSize: integer): boolean;
var nsent: DWORD;
begin
 Result := WriteFile( FComPortHandle, DataPtr^, DataSize, nsent, nil );
 Result := Result and (nsent=DataSize);
end;
function TCommPortDriver.SendString( aStr: string ): boolean;
begin
 if not Connected then
 if not Connect then raise Exception.CreateHelp('RS232.SendString:'+
 ' Connect not possible !', 101);
 Result:=SendData( pchar(aStr), length(aStr) );
 if not Result then raise
 Exception.CreateHelp('RS232.SendString: Send not possible !', 102);
end;
// Event for teaching and messages
procedure TCommPortDriver.TimerEvent(Sender: TObject);
var InQueue, OutQueue: integer;
 // Test if data in inQueue(outQueue)
 procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: integer);
 var ComStat: TComStat;
 e: cardinal;
 begin
 aInQueue := 0;
 aOutQueue := 0;
 if ClearCommError(Handle, e, @ComStat) then
 begin
 aInQueue := ComStat.cbInQue;
 aOutQueue := ComStat.cbOutQue;
 end;
 end;
begin
 if not Connected then
 if not Connect then raise Exception.CreateHelp('RS232.TimerEvent:'+
 ' Connect not possible !', 101);
 if Connected then
 begin
 DataInBuffer(FComPortHandle, InQueue, OutQueue);
 // data in inQueue
 if InQueue > 0 then
 if Assigned(FComPortReceiveData) then FComPortReceiveData(Self , 0, 0, 0);
 end;
end;
// RS232 implementation ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
constructor TRS232.Create( AOwner: TComponent );
begin
 inherited Create( AOwner );
 //OnReceiveData := ReceiveData;
 FComPort := pnCOM1; // COM 1
 FComPortBaudRate := br9600; // 9600 bauds
 FComPortDataBits := db8BITS; // 8 data bits
 FComPortStopBits := sb1BITS; // 1 stop bits
 FComPortParity := ptEVEN; // even parity
 FComPortHwHandshaking := hhNONE; // no hardware handshaking
 FComPortSwHandshaking := shNONE; // no software handshaking
 FComPortInBufSize := 2048; // input buffer of 512 ? bytes
 FComPortOutBufSize := 2048; // output buffer of 512 ? bytes
 FTimeOut := 30; // sec until timeout
end;
function TRS232.ReadString(VAR aResStr: string; aCount: word ): boolean;
var
 nRead: dword;
 Buffer: string;
 Actual, Before: TDateTime;
 TimeOutMin, TimeOutSec, lCount: word;
begin
 Result := false;
 if not Connected then
 if not Connect then raise Exception.CreateHelp('RS232.ReadString:'+
 ' Connect not possible !', 101);
 aResStr := ;
 TimeOutMin:=TimeOut div 60;
 TimeOutSec:=TimeOut mod 60;
 if (not Connected) or (aCount <= 0) then EXIT;
 nRead := 0; lCount := 0;
 Before := Time;
 while lCount<aCount do
 begin
 Application.ProcessMessages;
 SetLength(Buffer,1);
 if ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil ) then
 begin
 if nRead > 0 then
 begin
 aResStr := aResStr + Buffer;
 inc(lCount);
 end;
 Actual := Time;
 if Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0)
 then raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103);
 end
 else begin
 raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104);
 end;
 end; // while
 Result:=true;
end;
[OBJECT]{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J+,K-,L-,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $51000000}
{$APPTYPE GUI}
unit ComportDriverThread;
interface
uses
 //Include "ExtCtrl" for the TTimer component.
 Windows, Messages, SysUtils, Classes, Forms, ExtCtrls;
type
 TComPortNumber = (pnCOM1,pnCOM2,pnCOM3,pnCOM4);
 TComPortBaudRate = (br110,br300,br600,br1200,br2400,br4800,br9600,
 br14400,br19200,br38400,br56000,br57600,br115200);
 TComPortDataBits = (db5BITS,db6BITS,db7BITS,db8BITS);
 TComPortStopBits = (sb1BITS,sb1HALFBITS,sb2BITS);
 TComPortParity = (ptNONE,ptODD,ptEVEN,ptMARK,ptSPACE);
 TComportHwHandshaking = (hhNONE,hhRTSCTS);
 TComPortSwHandshaking = (shNONE,shXONXOFF);
 TTimerThread = class(TThread)
 private
 { Private declarations }
 FOnTimer : TThreadMethod;
 FEnabled: Boolean;
 protected
 { Protected declarations }
 procedure Execute; override;
 procedure SupRes;
 public
 { Public declarations }
 published
 { Published declarations }
 property Enabled: Boolean read FEnabled write FEnabled;
 end;
 TComportDriverThread = class(TComponent)
 private
 { Private declarations }
 FTimer : TTimerThread;
 FOnReceiveData : TNotifyEvent;
 FReceiving : Boolean;
 protected
 { Protected declarations }
 FComPortActive : Boolean;
 FComportHandle : THandle;
 FComportNumber : TComPortNumber;
 FComportBaudRate : TComPortBaudRate;
 FComportDataBits : TComPortDataBits;
 FComportStopBits : TComPortStopBits;
 FComportParity : TComPortParity;
 FComportHwHandshaking : TComportHwHandshaking;
 FComportSwHandshaking : TComPortSwHandshaking;
 FComportInputBufferSize : Word;
 FComportOutputBufferSize : Word;
 FComportPollingDelay : Word;
 FTimeOut : Integer;
 FTempInputBuffer : Pointer;
 procedure SetComPortActive(Value: Boolean);
 procedure SetComPortNumber(Value: TComPortNumber);
 procedure SetComPortBaudRate(Value: TComPortBaudRate);
 procedure SetComPortDataBits(Value: TComPortDataBits);
 procedure SetComPortStopBits(Value: TComPortStopBits);
 procedure SetComPortParity(Value: TComPortParity);
 procedure SetComPortHwHandshaking(Value: TComportHwHandshaking);
 procedure SetComPortSwHandshaking(Value: TComPortSwHandshaking);
 procedure SetComPortInputBufferSize(Value: Word);
 procedure SetComPortOutputBufferSize(Value: Word);
 procedure SetComPortPollingDelay(Value: Word);
 procedure ApplyComPortSettings;
 procedure TimerEvent; virtual;
 procedure doDataReceived; virtual;
 public
 { Public declarations }
 constructor Create(AOwner: TComponent); override;
 destructor Destroy; override;
 function Connect: Boolean;
 function Disconnect: Boolean;
 function Connected: Boolean;
 function Disconnected: Boolean;
 function SendData(DataPtr: Pointer; DataSize: Integer): Boolean;
 function SendString(Input: String): Boolean;
 function ReadString(var Str: string): Integer;
 published
 { Published declarations }
 property Active: Boolean read FComPortActive write SetComPortActive default False;
 property ComPort: TComPortNumber read FComportNumber write SetComportNumber
 default pnCOM1;
 property ComPortSpeed: TComPortBaudRate read FComportBaudRate write
 SetComportBaudRate default br9600;
 property ComPortDataBits: TComPortDataBits read FComportDataBits write
 SetComportDataBits default db8BITS;
 property ComPortStopBits: TComPortStopBits read FComportStopBits write
 SetComportStopBits default sb1BITS;
 property ComPortParity: TComPortParity read FComportParity write
 SetComportParity default ptNONE;
 property ComPortHwHandshaking: TComportHwHandshaking read FComportHwHandshaking
 write SetComportHwHandshaking default
 hhNONE;
 property ComPortSwHandshaking: TComPortSwHandshaking read FComportSwHandshaking
 write SetComportSwHandshaking default
 shNONE;
 property ComPortInputBufferSize: Word read FComportInputBufferSize
 write SetComportInputBufferSize default
 2048;
 property ComPortOutputBufferSize: Word read FComportOutputBufferSize
 write SetComportOutputBufferSize default
 2048;
 property ComPortPollingDelay: Word read FComportPollingDelay write
 SetComportPollingDelay default 100;
 property OnReceiveData: TNotifyEvent read FOnReceiveData
 write FOnReceiveData;
 property TimeOut: Integer read FTimeOut write FTimeOut default 30;
 end;
procedure Register;
implementation
procedure Register;
begin
 RegisterComponents('Self-made Components', [TComportDriverThread]);
end;
{ TComportDriver }
constructor TComportDriverThread.Create(AOwner: TComponent);
begin
 inherited;
 FReceiving := False;
 FComportHandle := 0;
 FComportNumber := pnCOM1;
 FComportBaudRate := br9600;
 FComportDataBits := db8BITS;
 FComportStopBits := sb1BITS;
 FComportParity := ptNONE;
 FComportHwHandshaking := hhNONE;
 FComportSwHandshaking := shNONE;
 FComportInputBufferSize := 2048;
 FComportOutputBufferSize := 2048;
 FOnReceiveData := nil;
 FTimeOut := 30;
 FComportPollingDelay := 500;
 GetMem(FTempInputBuffer,FComportInputBufferSize);
 if csDesigning in ComponentState then
 Exit;
 FTimer := TTimerThread.Create(False);
 FTimer.FOnTimer := TimerEvent;
 if FComPortActive then
 FTimer.Enabled := True;
 FTimer.SupRes;
end;
destructor TComportDriverThread.Destroy;
begin
 Disconnect;
 FreeMem(FTempInputBuffer,FComportInputBufferSize);
 inherited Destroy;
end;
function TComportDriverThread.Connect: Boolean;
var
 comName: array[0..4] of Char;
 tms: TCommTimeouts;
begin
 if Connected then
 Exit;
 StrPCopy(comName,'COM');
 comName[3] := chr(ord('1') + ord(FComportNumber));
 comName[4] := #0;
 FComportHandle := CreateFile(comName,GENERIC_READ OR GENERIC_WRITE,0,nil,
 OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
 if not Connected then
 Exit;
 ApplyComPortSettings;
 tms.ReadIntervalTimeout := 1;
 tms.ReadTotalTimeoutMultiplier := 0;
 tms.ReadTotalTimeoutConstant := 1;
 tms.WriteTotalTimeoutMultiplier := 0;
 tms.WriteTotalTimeoutConstant := 0;
 SetCommTimeouts(FComportHandle,tms);
 Sleep(1000);
end;
function TComportDriverThread.Connected: Boolean;
begin
 Result := FComportHandle > 0;
end;
function TComportDriverThread.Disconnect: Boolean;
begin
 Result := False;
 if Connected then
 begin
 CloseHandle(FComportHandle);
 FComportHandle := 0;
 end;
 Result := True;
end;
function TComportDriverThread.Disconnected: Boolean;
begin
 if (FComportHandle <> 0) then
 Result := False
 else
 Result := True;
end;
const
 Win32BaudRates: array[br110..br115200] of DWORD =
 (CBR_110,CBR_300,CBR_600,CBR_1200,CBR_2400,CBR_4800,CBR_9600,CBR_14400,
 CBR_19200,CBR_38400,CBR_56000,CBR_57600,CBR_115200);
const
 dcb_Binary = $00000001;
 dcb_ParityCheck = $00000002;
 dcb_OutxCtsFlow = $00000004;
 dcb_OutxDsrFlow = $00000008;
 dcb_DtrControlMask = $00000030;
 dcb_DtrControlDisable = $00000000;
 dcb_DtrControlEnable = $00000010;
 dcb_DtrControlHandshake = $00000020;
 dcb_DsrSensitvity = $00000040;
 dcb_TXContinueOnXoff = $00000080;
 dcb_OutX = $00000100;
 dcb_InX = $00000200;
 dcb_ErrorChar = $00000400;
 dcb_NullStrip = $00000800;
 dcb_RtsControlMask = $00003000;
 dcb_RtsControlDisable = $00000000;
 dcb_RtsControlEnable = $00001000;
 dcb_RtsControlHandshake = $00002000;
 dcb_RtsControlToggle = $00003000;
 dcb_AbortOnError = $00004000;
 dcb_Reserveds = $FFFF8000;
procedure TComportDriverThread.ApplyComPortSettings;
var
 //Device Control Block (= dcb)
 dcb: TDCB;
begin
 if not Connected then
 Exit;
 FillChar(dcb,sizeOf(dcb),0);
 dcb.DCBlength := sizeOf(dcb);
 dcb.Flags := dcb_Binary or dcb_RtsControlEnable;
 dcb.BaudRate := Win32BaudRates[FComPortBaudRate];
 case FComportHwHandshaking of
 hhNONE : ;
 hhRTSCTS:
 dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
 end;
 case FComportSwHandshaking of
 shNONE : ;
 shXONXOFF:
 dcb.Flags := dcb.Flags or dcb_OutX or dcb_Inx;
 end;
 dcb.XonLim := FComportInputBufferSize div 4;
 dcb.XoffLim := 1;
 dcb.ByteSize := 5 + ord(FComportDataBits);
 dcb.Parity := ord(FComportParity);
 dcb.StopBits := ord(FComportStopBits);
 dcb.XonChar := #17;
 dcb.XoffChar := #19;
 SetCommState(FComportHandle,dcb);
 SetupComm(FComportHandle,FComPortInputBufferSize,FComPortOutputBufferSize);
end;
function TComportDriverThread.ReadString(var Str: string): Integer;
var
 BytesTrans, nRead: DWORD;
 Buffer : String;
 i : Integer;
 temp : string;
begin
 BytesTrans := 0;
 Str := ;
 SetLength(Buffer,1);
 ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
 while nRead > 0 do
 begin
 temp := temp + PChar(Buffer);
 ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
 end;
 //Remove the end token.
 BytesTrans := Length(temp);
 SetLength(str,BytesTrans-2);
 for i:=0 to BytesTrans-2 do
 begin
 str[i] := temp[i];
 end;
 Result := BytesTrans;
end;
function TComportDriverThread.SendData(DataPtr: Pointer;
 DataSize: Integer): Boolean;
var
 nsent : DWORD;
begin
 Result := WriteFile(FComportHandle,DataPtr^,DataSize,nsent,nil);
 Result := Result and (nsent = DataSize);
end;
function TComportDriverThread.SendString(Input: String): Boolean;
begin
 if not Connected then
 if not Connect then
 raise Exception.CreateHelp('Could not connect to COM-port !',101);
 Result := SendData(PChar(Input),Length(Input));
 if not Result then
 raise Exception.CreateHelp('Could not send to COM-port !',102);
end;
procedure TComportDriverThread.TimerEvent;
var
 InQueue, OutQueue: Integer;
 Buffer : String;
 nRead : DWORD;
 procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: Integer);
 var
 ComStat : TComStat;
 e : Cardinal;
 begin
 aInQueue := 0;
 aOutQueue := 0;
 if ClearCommError(Handle,e,@ComStat) then
 begin
 aInQueue := ComStat.cbInQue;
 aOutQueue := ComStat.cbOutQue;
 end;
 end;
begin
 if csDesigning in ComponentState then
 Exit;
 if not Connected then
 if not Connect then
 raise Exception.CreateHelp('TimerEvent: Could not connect to COM-port !',101);
 Application.ProcessMessages;
 if Connected then
 begin
 DataInBuffer(FComportHandle,InQueue,OutQueue);
 if InQueue > 0 then
 begin
 if (Assigned(FOnReceiveData) ) then
 begin
 FReceiving := True;
 FOnReceiveData(Self);
 end;
 end;
 end;
end;
procedure TComportDriverThread.SetComportBaudRate(Value: TComPortBaudRate);
begin
 FComportBaudRate := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportDataBits(Value: TComPortDataBits);
begin
 FComportDataBits := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportHwHandshaking(Value: TComportHwHandshaking);
begin
 FComportHwHandshaking := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportInputBufferSize(Value: Word);
begin
 FreeMem(FTempInputBuffer,FComportInputBufferSize);
 FComportInputBufferSize := Value;
 GetMem(FTempInputBuffer,FComportInputBufferSize);
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportNumber(Value: TComPortNumber);
begin
 if Connected then
 exit;
 FComportNumber := Value;
end;
procedure TComportDriverThread.SetComportOutputBufferSize(Value: Word);
begin
 FComportOutputBufferSize := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportParity(Value: TComPortParity);
begin
 FComportParity := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportPollingDelay(Value: Word);
begin
 FComportPollingDelay := Value;
end;
procedure TComportDriverThread.SetComportStopBits(Value: TComPortStopBits);
begin
 FComportStopBits := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportSwHandshaking(Value: TComPortSwHandshaking);
begin
 FComportSwHandshaking := Value;
 if Connected then
 ApplyComPortSettings;
end;
procedure TComportDriverThread.DoDataReceived;
begin
 if Assigned(FOnReceiveData) then FOnReceiveData(Self);
end;
procedure TComportDriverThread.SetComPortActive(Value: Boolean);
var
 DumpString : String;
begin
 FComPortActive := Value;
 if csDesigning in ComponentState then
 Exit;
 if FComPortActive then
 begin
 //Just dump the contents of the input buffer of the com-port.
 ReadString(DumpString);
 FTimer.Enabled := True;
 end
 else
 FTimer.Enabled := False;
 FTimer.SupRes;
end;
{ TTimerThread }
procedure TTimerThread.Execute;
begin
 Priority := tpNormal;
 repeat
 Sleep(500);
 if Assigned(FOnTimer) then Synchronize(FOnTimer);
 until Terminated;
end;
procedure TTimerThread.SupRes;
begin
 if not Suspended then
 Suspend;
 if FEnabled then
 Resume;
end;
end.
procedure TCommPortDriver.SetActive(const Value: boolean);
begin
 FActive := Value;
end;
end.
Source: Взято из http://forum.sources.ru
ID: 01346