Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007

Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс 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.

Взято из https://forum.sources.ru

procedure TCommPortDriver.SetActive(const Value: boolean);
begin
  FActive := Value;
end;
 
end.

Взято из https://forum.sources.ru