我写的一个串口通讯控件，经过长期使用证明，很好用的。参考了comm32,及spcomm等。主要是修正了comm32中的.pas

别人写的一个串口通讯控件

unit KComm;

interface

uses
  SysUtils, Classes,Messages, Windows, Forms;
const
  EM_ONREAD = WM_USER + 101;
type
  ECommError = class(Exception)
    ErrorCode: Integer;
  end;
  TBaudrate =(br110, br300, br600, br1200, br2400, br4800, br9600, br14400,
    br19200, br38400, br56000, br57600, br115200, br128000, br256000);
  TParity = (paNone, paOdd, paEven, paMark, paSpace);
  TStopbits = (sb10, sb15, sb20);
  TDatabits=(da4, da5, da6, da7, da8);
  TFlowControl = (fcNone, fcCTS, fcDTR, fcSoftware, fcDefault);
  TReceiveDataEvent = procedure(Sender: TObject; Buffer: PChar;
                                  Count: Word) of object;
  TCommEvent = procedure(Sender: TObject; Count: integer) of object;
  TOnStateEvent = procedure(Sender: TObject; State: DWord) of object;
  TKComm = class;
  
  TReadThread = class( TThread )
  private
    hCommFile: THandle;
    kcomm: TKcomm;
    hEvent: THandle;
    FOnState: TOnStateEvent;
    procedure ReadPort;
  protected
    procedure BreakEvent; //终止事件等等，结束Execute
    procedure Execute; override;
  public
    constructor Create(Handle: THandle;comm: TKComm);
    destructor Destroy; override;
    property OnState:TOnStateEvent read FOnState write FOnState;
  end;

  TKComm = class(TComponent)
  private
    hCommFile: THandle;
    ReadThread: TReadThread;
    FWriteBufSize: Integer;
    FReadBufSize: Integer;
    FComPort: string;
    FBaudRate: TBaudRate;
    FDatabits: TDatabits;
    FStopbits: TStopbits;
    FParity: TParity;
    FWriteTimeout: Integer;
    FReadTimeout: Integer;
    FOnRead: TReceiveDataEvent;
    FOnState: TOnStateEvent;
    procedure SetBaudRate(const Value: TBaudRate);
    procedure SetComPort(const Value: string);
    procedure SetDatabits(const Value: TDatabits);
    procedure SetReadBufSize(const Value: Integer);
    procedure SetStopbits(const Value: TStopbits);
    procedure SetWriteBufSize(const Value: Integer);
    procedure SetParity(const Value: TParity);
  private
    hEvent: THandle;
  protected
    function GetModemState(Index: Integer): Boolean;
    procedure UpdateDataControlBlock;
    procedure UpdateCommTimeouts;
    procedure CreateHandle; virtual;
    procedure DestroyHandle;
    procedure ReadPort(Sender: TObject);  //后台读数据
    procedure ProcessOnState(Sender: TObject; State: DWord);
    procedure Emread(var Message: TMessage); message EM_ONREAD;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function OPened: Boolean;    //串口是否打开
    function OpenComm: Boolean;        //打开串口
    procedure CloseComm;      //关闭串口
    function Write(var Buf; Count: Integer): Integer;  //写数据
    function InQueCount: Integer;                      //读缓冲区数据长度
    function OutQueCount: Integer;                     //写缓冲区未发送数据长度
    procedure ClearComm;   //清除端口缓冲区
    {Comm escape functions}
    procedure SetDTRState(State: Boolean);       //True 为高电压， false 为低电压
    procedure SetRTSState(State: Boolean);
    {Comm status flags}
    property CTS: Boolean index 1 read GetModemState;
    property DSR: Boolean index 2 read GetModemState;
  published
    property ReadTimeout: Integer read FReadTimeout write FReadTimeout default 200; //读超时
    property WriteTimeout: Integer read FWriteTimeout write FWriteTimeout default 200; //写超时
    property BaudRate: TBaudRate read FBaudRate write SetBaudRate default br9600;  //波特率
    property Databits: TDatabits read FDatabits write SetDatabits default da8;     //数据位
    property Stopbits: TStopbits read FStopbits write SetStopbits default sb10;    //停止位
    property Parity: TParity read FParity write SetParity default paNone;          //奇偶较验
    property ComPort: string read FComPort write SetComPort;                    //打开串口名
    property ReadBufSize: Integer read FReadBufSize write SetReadBufSize  default 2048;   //读缓冲区大小
    property WriteBufSize: Integer read FWriteBufSize write SetWriteBufSize default 2048;  //写缓冲区大小
    property OnRead: TReceiveDataEvent read FOnRead write FOnRead;
    property OnState:TOnStateEvent read FOnState write FOnState;    
  end;

procedure Register;
implementation
const
  sMsgExtention = ' (通讯错误: %d) ';
  CommBaudRates: array[TBaudRate] of Integer =
    ( 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,
      CBR_128000,
      CBR_256000);

  CommDataBits: array[TDatabits] of Integer =
    ( 4, 5, 6, 7, 8);

  CommParity: array[TParity] of Integer =
    ( NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);

  CommStopBits: array[TStopbits] of Integer =
    ( ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS );

procedure Register;
begin
  RegisterComponents('KStand', [TKComm]);
end;

procedure RaiseCommError(Msg: string; ErrCode: Integer);
var
  E: ECommError;
begin
  E := ECommError.Create(Msg + Format(sMsgExtention, [ErrCode]));
  E.ErrorCode := ErrCode;
  raise E;
end; { RaiseCommError }
{ TKComm }

procedure TKComm.ClearComm;
begin
  if OPened then begin
    FlushFileBuffers(hCommFile); //完成未完成的传输操作
    PurgeComm(hCommFile, PURGE_RXABORT + PURGE_RXCLEAR +
      PURGE_TXABORT + PURGE_TXCLEAR)
  end else RaiseCommError('串口没打开不能执行清空命令',-1);
end;

procedure TKComm.CloseComm;
var
  t1, t2: DWord;
begin
  if Opened then
  begin
    ReadThread.Terminate;
    ReadThread.BreakEvent;
    SetEvent(hEvent);
    t1 := GetTickcount;
    t2 := t1;
    while (t2 - t1) < 200 do begin //用于等待线程中被等待同步执行的ReadPort函数可以得到执行，要不然会报IO错误.
      Application.ProcessMessages;
      t2 := GetTickCount;
    end;
    DestroyHandle;
    CloseHandle(hEvent);
  end;
end;

constructor TKComm.Create(AOwner: TComponent);
begin
  inherited;
  FComPort := 'Com1';
  hCommFile := INVALID_HANDLE_VALUE;
  FReadBufSize := 2048;
  FWriteBufSize := 2048;
  FReadTimeout := 500;
  FWriteTimeout := 500;
  FBaudRate := br9600;
  FParity := paNone;
  FStopbits := sb10;
  FDatabits := da8;
  ReadThread := nil;
end;

procedure TKComm.CreateHandle;
begin
  hCommFile := CreateFile(PCHAR(FComPort),
    GENERIC_READ or GENERIC_WRITE, 0, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);

  if not Opened then RaiseCommError('串口不能打开', GetLastError);
  if GetFileType(hCommFile) <> FILE_TYPE_CHAR then
  begin
    DestroyHandle;
    RaiseCommError('打开文件类型不对', -1);
  end;
end;

destructor TKComm.Destroy;
begin
  CloseComm;
  inherited;
end;

{
  1: cts
  2: dsr
}
procedure TKComm.DestroyHandle;
begin
  CloseHandle(hCommFile);
  hCommFile := INVALID_HANDLE_VALUE;
end;

procedure TKComm.Emread(var Message: TMessage);
begin

end;

function TKComm.GetModemState(Index: Integer): Boolean;
var
  Flag, State: dword;
begin
  case Index of
    1: State := MS_CTS_ON;
    2: State := MS_DSR_ON;
    else
      State := 0;
  end;
  Result := false;
  if Opened then
    if GetCommModemStatus(hCommFile, Flag) then
      Result := (Flag and State > 0);
end;

function TKComm.InQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Opened then
  begin
    ClearCommError(hCommFile, Errors, @ComStat);
    Result := ComStat.cbInQue;
  end else Result := -1;
end;

function TKComm.OpenComm: Boolean;
var
  FEventD: Dword;
begin
  Result := true;
  if Opened then exit;
  CreateHandle;
  UpdateDataControlBlock;
  UpdateCommTimeouts;
  FEventD := EV_CTS or EV_DSR or EV_RXCHAR or EV_TXEMPTY;
  if not SetupComm(hCommFile, FReadBufSize, FWriteBufSize) then
    RaiseCommError('不能设置读写缓冲区大小', GetLastError);
  if not SetCommMask(hCommFile, FEventD) then
      RaiseCommError('不能设置事件', GetLastError);

  ClearComm;
  hEvent := CreateEvent(nil, True, false, nil);
  ReadThread := TReadThread.Create(hCommFile, self);
  ReadThread.OnState := ProcessOnState;
end;

function TKComm.OPened: Boolean;
begin
  Result := hCommFile <> INVALID_HANDLE_VALUE;
end;

function TKComm.OutQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Opened then
  begin
    ClearCommError(hCommFile, Errors, @ComStat);
    Result := ComStat.cbOutQue;
  end else Result := -1;
end;

procedure TKComm.ProcessOnState(Sender: TObject; State: DWord);
var
  dwError: DWord;
begin
  dwError := 0;
  if (State and EV_CTS) <> 0 then dwError := 1;
  if (State and EV_DSR) <> 0 then dwError := 2;
  if (State and EV_RXCHAR) <> 0 then dwError := 3;
  if (State and EV_TXEMPTY) <> 0 then dwError := 4;
  if Assigned(FOnState) then FOnState(self, dwError);
end;

procedure TKComm.ReadPort(Sender: TObject);
var
  inbuf: PChar;
  cs: TcomStat;
  dwError, WEResult, nBytesRead: Dword;
  OverLap: TOverlapped;
begin
  ClearCommError(hCommFile, dwError, @cs);
  {$IFOPT D+}
  if (dwError and CE_IOE) <> 0 then RaiseCommError('串口IO错误', -1);
  if (dwError and CE_OVERRUN) <> 0 then RaiseCommError('串口缓冲区不足', -1);
  if (dwError and CE_RXPARITY) <> 0 then RaiseCommError('串口校检位出错', -1);
  if (dwError and CE_TXFULL) <> 0 then RaiseCommError('串口缓冲区已满', -1);
  {$ENDIF}
  if cs.cbInQue = 0 then exit;
  if cs.cbInQue > FReadBufSize then begin
    PurgeComm(hCommFile, PURGE_RXCLEAR);
    exit;
  end;
  GetMem(inbuf, cs.cbInQue);
  FillChar(inbuf[0], cs.cbInQue, 0);
  FillChar( OverLap, Sizeof(TOverlapped), 0 );
  OverLap.hEvent := hEvent;
  if not ReadFile(hCommFile, inbuf[0], cs.cbInQue, nBytesRead,@OverLap)
    and (GetLastError <> ERROR_IO_PENDING) then
    RaiseCommError('读串口错误',GetLastError);

  WEResult:= WaitForSingleObject(hEvent,FReadTimeout); // 等 待 同 步 事件 置 位；
  ResetEvent(hEvent);
  if (WEResult = WAIT_OBJECT_0) and (nBytesRead <> 0) and Assigned(FOnRead)
    then    FOnRead(self, inbuf, nBytesRead);
  FreeMem(inbuf);
end;

procedure TKComm.SetBaudRate(const Value: TBaudRate);
begin
  FBaudRate := Value;
  UpdateDataControlBlock;
end;

procedure TKComm.SetComPort(const Value: string);
begin
  if FComPort <> Value then
  begin
    if Opened then RaiseCommError('串口已打开，重新指定前请先关闭', -1);
    FComPort := Value;
  end;
end;

procedure TKComm.SetDatabits(const Value: TDatabits);
begin
  FDatabits := Value;
  UpdateDataControlBlock;
end;

procedure TKComm.SetDTRState(State: Boolean);
const
  CDTR: array[boolean] of Integer = (CLRDTR, SETDTR);
begin
  if Opened then EscapeCommFunction(HCommFile, CDTR[State])
  else RaiseCommError('串口没有打开，不能设置DTR状态',-1);
end;

procedure TKComm.SetParity(const Value: TParity);
begin
  FParity := Value;
  UpdateDataControlBlock;
end;

procedure TKComm.SetReadBufSize(const Value: Integer);
begin
  if FReadBufSize <> Value then
  begin
    if Opened then RaiseCommError('不能在打开串口时设置读缓冲区大小', -1);
    FReadBufSize := Value;
  end;
end;

procedure TKComm.SetRTSState(State: Boolean);
const
  CRTS: array[boolean] of Integer = (CLRRTS, SETRTS);
begin
  if Opened then EscapeCommFunction(HCommFile, CRTS[State])
  else RaiseCommError('串口没有打开，不能设置RTS状态',-1);
end;

procedure TKComm.SetStopbits(const Value: TStopbits);
begin
  FStopbits := Value;
  UpdateDataControlBlock;
end;

procedure TKComm.SetWriteBufSize(const Value: Integer);
begin
  if FWriteBufSize <> Value then
  begin
    if Opened then RaiseCommError('不能在打开串口时设置写缓冲区大小', -1);
    FWriteBufSize := Value;
  end;
end;

procedure TKComm.UpdateCommTimeouts;
var
  CommTimeouts: TCommTimeouts;
begin
  GetCommTimeouts( hCommFile, commtimeouts );
  CommTimeouts.ReadIntervalTimeout := MAXDWORD;
  commtimeouts.ReadTotalTimeoutMultiplier  := 0;
	commtimeouts.ReadTotalTimeoutConstant    := 0;
	commtimeouts.WriteTotalTimeoutMultiplier := 0;
	commtimeouts.WriteTotalTimeoutConstant   := 0;

  if not SetCommTimeOuts(hCommFile, CommTimeOuts) then
    RaiseCommError('设置读写超时时出错', GetLastError);
end;

procedure TKComm.UpdateDataControlBlock;
var
  cc: TCOMMCONFIG;
begin
  if OPened then
  begin
    GetCommState(hCommFile, cc.dcb);
    cc.dcb.BaudRate := CommBaudRates[FBaudRate];
    cc.dcb.Parity := CommParity[FParity];
    cc.dcb.StopBits := CommStopbits[FStopbits];
    cc.dcb.ByteSize := CommDatabits[FDatabits];
    if Not SetCommState(hCommFile, cc.dcb) then
      RaiseCommError('在更新状态DCB设置时出错', GetLastError);
  end;
end;

function TKComm.Write(var Buf; Count: Integer): Integer;
var
  lrc , dwError, WEResult: DWord;
  OverLap: TOverlapped;
  cs: TComStat;
begin
  if (hCommFile = INVALID_HANDLE_VALUE) then
    RaiseCommError('串口关闭时不能写数据', -1);
  ClearCommError(hCommFile, dwError, @cs);
  if (WriteBufSize -cs.cbOutQue) <= Count then sleep(200);  
  FillChar( OverLap, Sizeof(TOverlapped), 0 );
  OverLap.hEvent := hEvent;
  if WriteFile(hCommFile,Buf, Count, lrc, @OverLap) and
      (GetLastError <> ERROR_IO_PENDING) then
      RaiseCommError('写串口时失败',GetLastError);
  WEResult:= WaitForSingleObject(hEvent,FWriteTimeout); // 等 待 同 步 事件 置 位；
  ResetEvent(hEvent);
  if WEResult = WAIT_OBJECT_0 then
     GetOverlappedResult(hCommFile, OverLap, dWord(Result), False)
  else Result := -1;
end;

{ TReadThread }

constructor TReadThread.Create(Handle: THandle; comm: TKComm);
begin
  FreeOnTerminate := True;
  hCommFile := Handle;
  kcomm:= comm;
  hEvent := CreateEvent(nil, True, false, nil);
  inherited Create(false);  //打开即执行
end;

destructor TReadThread.Destroy;
begin
  CloseHandle(hEvent);
  inherited;
end;

procedure TReadThread.Execute;
var
  dwError: Dword;
  OverLap: TOverlapped;
  WEResult : DWord;
begin
  FillChar( OverLap, Sizeof(TOverlapped), 0 );
  OverLap.hEvent := hEvent;
  while (not Terminated) do
  begin
    if WaitCommEvent(hCommFile, dwError, @OverLap) or (GetLastError = ERROR_IO_PENDING) then
    begin
      WEResult:= WaitForSingleObject(hEvent,infinite); // 等 待 同 步 事件 置 位；
      ResetEvent(hEvent);
      if WEResult = WAIT_OBJECT_0 then Synchronize(ReadPort);
      if (dwError <> 0) and Assigned(FOnState) then FOnState(self, dwError); //状态改变事件
    end;
  end;
  FlushFileBuffers(hCommFile); //完成未完成的传输操作
  PurgeComm(hCommFile, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); //清并终止所有读写操作
end;

procedure TReadThread.ReadPort;
begin
  kcomm.ReadPort(self);
end;

procedure TReadThread.BreakEvent;
begin
  SetEvent(hEvent);
end;

end.