mycomm32.pas

windows 下的多线程串口通讯组件。纯delphi源代码

//------------吴志辉  2002-10改写------------//
//[e-mail]----------------//
//------------感谢 Marco Cocco---------------//

unit MyComm32;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const
  // ----messages from read/write threads---//
  PWM_GOTCOMMDATA = WM_USER + 1;
  MAXOUTPUTSTRINGLENGTH = 8192;
  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;

type
  
  TComPortHwHandshaking = ( hhNONE, hhRTSCTS );  // COM Port Hardware Handshaking硬件握手信号
  TComPortSwHandshaking = ( shNONE, shXONXOFF ); // COM Port Software Handshaing 软件握手信号
  TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS );   // COM Port Data  bits 数据位
  TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS );        // COM Port Stop  bits 停止位
  TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE ); // COM Port Parity Type校验位

  ECommsError = class( Exception );

  TReadThread = class( TThread )
  protected
    procedure Execute; override;
    public
      hCommFile: 	THandle;
      hCloseEvent:	THandle;
      hMyComportWindow:	THandle;
      function SetupCommEvent( lpOverlappedCommEvent: POverlapped;
      		      	var lpfdwEvtMask: DWORD ): Boolean;
      function SetupReadEvent( lpOverlappedRead: POverlapped;
		      	lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
		      	var lpnNumberOfBytesRead: DWORD ): Boolean;
      function HandleCommEvent( lpOverlappedCommEvent: POverlapped;
                    	var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean;
      function HandleReadEvent( lpOverlappedRead: POverlapped;
		      	lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
		      	var lpnNumberOfBytesRead: DWORD ): Boolean;
      function HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean;
      function ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL;
    end;

  TWriteThread = class( TThread )
    protected
      procedure Execute; override;
      function HandleWriteData( lpOverlappedWrite: POverlapped;
		pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
    public
      hCommFile: 	THandle;
      hCloseEvent:	THandle;
      hMyComportWindow:	THandle;
      function WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
    end;

  TReceiveDataEvent = procedure( Buffer: PChar; BufferLength: Word ) of object;

  TMyComport = class( TComponent )
    private
      ReadThread  : TReadThread;   //---读线程
      WriteThread : TWriteThread;  //---写线程
      FCommsLogFileName:String;    //---记录文件
      hCommFile:  	  THandle;   //---通讯设备文件句柄
      hCloseEvent:	  THandle;   //---结束通讯事件
      FOnReceiveData:     TReceiveDataEvent;    //---读出数据
      FHWnd:		  THandle;    //---不可见通讯窗口句柄

      procedure SetCommsLogFileName( LogFileName: string );
      function  GetReceiveDataEvent: TReceiveDataEvent;
      procedure SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent );
      procedure CommWndProc( var msg: TMessage );

    protected{ Protected declarations }
      FCommPort         : string;                    //通讯端口
      FComPortBaudRate  : DWORD;            //波特率
      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)
      FReadTimeout      : WORD;
      FComPortHwHandshaking:TComPortHwHandshaking; // Type of hw handshaking to use
      FComPortSwHandshaking:TComPortSwHandshaking; // Type of sw handshaking to use
      FEnableDTROnOpen: Boolean; // enable/disable DTR line on connect

      procedure CloseReadThread;
      procedure CloseWriteThread;
      procedure SetComPortDataBits( Value: TComPortDataBits );
      procedure SetComPortStopBits( Value: TComPortStopBits );
      procedure SetComPortParity( Value: TComPortParity );

      procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking );
      procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking );
      procedure ReceiveData( Buffer: PChar; BufferLength: Word );
      //set DTR line high (onOff=TRUE) or low (onOff=FALSE).You must not use HW handshaking.
      procedure ToggleDTR( onOff: boolean );
      //set RTS line high (onOff=TRUE) or low (onOff=FALSE).You must not use HW handshaking.
      procedure ToggleRTS( onOff: boolean );
      procedure ApplyCOMSettings;
      
    public
      constructor Create( AOwner: TComponent ); override;
      destructor  Destroy; override;
      function    StartComm: Boolean;
      procedure   StopComm;
      function    WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;

    published
      property CommPort: string read FCommPort write FCommPort;
      property ComPortBaudRate: DWORD read FComPortBaudRate write FComPortBaudRate default 9600;
      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;
      // 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;
      property CommFileHandle: THandle Read hCommFile;
      property ReadTimeout: WORD read FReadTimeout write FReadTimeout default 20;
      property EnableDTROnOpen: boolean read FEnableDTROnOpen write FEnableDTROnOpen default True;      
      property CommsLogFileName: string read FCommsLogFileName write SetCommsLogFileName;
      property OnReceiveData: TReceiveDataEvent
                read GetReceiveDataEvent write SetReceiveDataEvent;
    end;

const
  // This is the message posted to the WriteThread
  // When we have something to write.
  PWM_COMMWRITE = WM_USER+1;
  // Default size of the Input Buffer used by this code.
  INPUTBUFFERSIZE =2048;
  
var // means you can only debug 1 component at a time
  CommsLogFile:	TextFile;

Function MAKELANGID( usPrimaryLanguage, usSubLanguage: Byte ): WORD;
Function FormatLastError( dwLastError: DWORD;
	 szOutputBuffer: PChar; dwSizeofOutputBuffer: DWORD ): PChar;
procedure LogDebugInfo( outstr: PChar );
procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR );
procedure Register;

implementation

var
  CommsLogName:	string; // used as a check if file is assigned

(****************************************************************)
// 		TMyComport PUBLIC METHODS
(****************************************************************)
constructor TMyComport.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  FCommPort                  := 'COM1';
  FComPortBaudRate           := 9600;    // 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
  FOnReceiveData             := nil;     // no data handler
  FEnableDTROnOpen           := True;    // DTR high on connect
  FReadTimeout               := 10;
  FCommsLogFileName :='';
  CommsLogName := '';
  ReadThread := nil;
  WriteThread := nil;
  hCommFile := 0;
  if not (csDesigning in ComponentState) then
   	FHWnd := AllocateHWnd(CommWndProc);  //----创建隐藏窗口 便于消息传送---//
end;

destructor TMyComport.Destroy;
begin
  if not (csDesigning in ComponentState) then
    DeallocateHWnd(FHwnd);
  inherited Destroy;
end;

procedure TMyComport.SetComPortDataBits( Value: TComPortDataBits );
begin
  FComPortDataBits := Value;
  if hCommFile<>0 then  ApplyCOMSettings;
end;

procedure TMyComport.SetComPortStopBits( Value: TComPortStopBits );
begin
  FComPortStopBits := Value;
  if hCommFile<>0 then  ApplyCOMSettings;
end;

procedure TMyComport.SetComPortParity( Value: TComPortParity );
begin
  FComPortParity := Value;
  if hCommFile<>0 then  ApplyCOMSettings;
end;

procedure TMyComport.SetComPortHwHandshaking( Value: TComPortHwHandshaking );
begin
  FComPortHwHandshaking := Value;
  if hCommFile<>0 then  ApplyCOMSettings;
end;

procedure TMyComport.SetComPortSwHandshaking( Value: TComPortSwHandshaking );
begin
  FComPortSwHandshaking := Value;
  if hCommFile<>0 then  ApplyCOMSettings;
end;

//--set DTR line high (onOff=TRUE) or low (onOff=FALSE).--//
//------------------You must not use HW handshaking-------// 
procedure TMyComPort.ToggleDTR( onOff: boolean );
const funcs: array[boolean] of DWORD = (CLRDTR,SETDTR);
begin
  if hCommFile<>0  then
    EscapeCommFunction( hCommFile,
       funcs[onOff] );
end;

//--- set RTS line high (onOff=TRUE) or low (onOff=FALSE).--//
//----------------You must not use HW handshaking.----------//
procedure TMyComPort.ToggleRTS( onOff: boolean );
const funcs: array[boolean] of DWORD = (CLRRTS,SETRTS);
begin
  if hCommFile<>0  then
    EscapeCommFunction( hCommFile, funcs[onOff] );
end;


procedure TMyComPort.ApplyCOMSettings;
Var commtimeouts:TCommTimeouts;
    dcb:    	TDcb;
    commprop:	TCommProp;
    fdwEvtMask:	DWORD;
begin
  if hCommFile=0 then Exit;
  GetCommState( hCommFile, dcb );
  GetCommProperties( hCommFile, commprop );
  GetCommMask( hCommFile, fdwEvtMask);
  GetCommTimeouts( hCommFile, commtimeouts);
  //---------设置读出延时设置------------------//
  commtimeouts.ReadIntervalTimeout:=FReadTimeout;
  commtimeouts.ReadTotalTimeoutMultiplier  := 0;
  commtimeouts.ReadTotalTimeoutConstant    := 0;
  commtimeouts.WriteTotalTimeoutMultiplier := 0;
  commtimeouts.WriteTotalTimeoutConstant   := 0;
  if SetCommTimeouts(hCommFile, commtimeouts ) then
    LogDebugInfo(Pchar(TimetoStr(Time)+' SetCommTimeouts OK'));

  //----------DCB设置-------------//
  dcb.DCBlength :=sizeof(TDCB);
  dcb.BaudRate := FComPortBaudRate;
  dcb.Flags := dcb_Binary OR dcb.Flags;
  if EnableDTROnOpen then  //Enabled the DTR line when the device is opened and leaves it on
    dcb.Flags := dcb.Flags or dcb_DtrControlEnable;

  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 := INPUTBUFFERSIZE div 4; 
  dcb.XOFFLim := 1;
  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

  if not SetCommState( hCommFile, dcb ) then
    LogDebugInfo(Pchar(TimetoStr(Time)+' SetCommState OK'));

end;

Function TMyComport.StartComm: Boolean;
var
  hNewCommFile:   THandle;
begin  
  Result:=False;
  if (hCommFile <> 0) then   //正在使用端口,不能改变
    begin
      LogDebugInfo(Pchar(TimetoStr(Time)+' 端口已经打开'+FCommPort));
      Exit;
    end;

  if CommsLogFileName <> '' then  //----打开记录文件-----//
    begin
      AssignFile( CommsLogFile, CommsLogFileName );
      Rewrite(CommsLogFile );
    end;

  hNewCommFile := CreateFile(PChar(FCommPort),
    			   GENERIC_READ+GENERIC_WRITE,
    			   0,
    			   nil,
    			   OPEN_EXISTING,
    			   FILE_FLAG_OVERLAPPED,// OR             FILE_ATTRIBUTE_NORMAL,
             0 );
  if hNewCommFile = INVALID_HANDLE_VALUE then
    begin
      LogDebugInfo(Pchar('打开端口失败:'+FCommPort));
      Exit;
    end;

  if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then
    begin
      LogDebugInfo(Pchar('打开端口类型错误:'+FCommPort));
      Exit;
    end;
    
  LogDebugInfo(Pchar(TimetoStr(Time)+' 打开'+fCommPort+'成功'));
  //--------------Comport ok, continue-----------------//
  hCommFile := hNewCommFile;
  ApplyCOMSettings;    //---设置可调通讯参数----//

  //----Create the event that will signal the threads to close-----//
  hCloseEvent := CreateEvent( nil, True, False, nil ); //nonsignaled
  if hCloseEvent = 0 then
    begin
      LogDebugInfo('不能创建关闭事件CloseEvent!');
      StopComm;
      hCommFile := 0;
      Result := False;
      Exit
    end;

  //--- Create the Read thread ------//
  try
    ReadThread := TReadThread.Create(True); {suspended}
  except
    LogDebugInfo('不能创建Read thread');
    Abort;
  end;
  ReadThread.hCommFile := hCommFile;
  ReadThread.hCloseEvent := hCloseEvent;
  ReadThread.hMyComportWindow := FHWnd;  //---接受消息的窗口
  ReadThread.Resume;
  //ReadThread.Priority := tpHighest;  //---值得考虑改写----//

  //-----Create the Write thread----//
  try
    WriteThread := TWriteThread.Create(True); {suspended}
  except
    LogDebugInfo('不能创建Write thread' );
    Abort;
  end;
  WriteThread.hCommFile := hCommFile;
  WriteThread.hCloseEvent := hCloseEvent;
  WriteThread.hMyComportWindow := FHWnd; //---接受消息的窗口
  WriteThread.Resume;
  WriteThread.Priority := tpHigher;
  
  //------Everything was created ok.  Ready to go!
  Result := True;
end; {TMyComport.StartComm}

procedure TMyComport.StopComm;
begin
  if hCommFile = 0 then Exit;
     LogDebugInfo( Pchar(TimetoStr(Time)+' Stopping the Comm'));
  //----Close the threads.---//