spcomm.pas

DELPHI串口通讯程序

unit SPComm;

interface

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

const
 // messages from read/write threads
  PWM_GOTCOMMDATA = WM_USER + 1;
  PWM_RECEIVEERROR = WM_USER + 2;
  PWM_REQUESTHANGUP = WM_USER + 3;
  PWM_MODEMSTATECHANGE = WM_USER + 4;
  PWM_SENDDATAEMPTY = WM_USER + 5;

type
    TParity = ( None, Odd, Even, Mark, Space );
    TStopBits = ( _1, _1_5, _2 );
    TByteSize = ( _5, _6, _7, _8 );
    TDtrControl = ( DtrEnable, DtrDisable, DtrHandshake );
    TRtsControl = ( RtsEnable, RtsDisable, RtsHandshake, RtsTransmissionAvailable );

    ECommsError = class( Exception );
    TReceiveDataEvent = procedure(Sender: TObject; Buffer: Pointer;
                                  BufferLength: Word) of object;
    TReceiveErrorEvent = procedure(Sender: TObject; EventMask : DWORD) of object;
    TModemStateChangeEvent = procedure(Sender: TObject; ModemEvent : DWORD) of object;
    TSendDataEmptyEvent = procedure(Sender: TObject) of object;

const
     // Modem Event Constant
  ME_CTS = 1;
  ME_DSR = 2;
  ME_RING = 4;
  ME_RLSD = 8;

type
    TReadThread = class( TThread )
    protected
      procedure Execute; override;
    public
      hCommFile:          THandle;
      hCloseEvent:        THandle;
      hComm32Window:      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;
      function ReceiveError( EvtMask : DWORD ): BOOL;
      function ModemStateChange( ModemEvent : DWORD ) : BOOL;
      procedure PostHangupCall;
    end;

    TWriteThread = class( TThread )
    protected
      procedure Execute; override;
      function HandleWriteData( lpOverlappedWrite: POverlapped;
                                pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
    public
      hCommFile:          THandle;
      hCloseEvent:        THandle;
      hComm32Window:      THandle;
      pFSendDataEmpty:    ^Boolean;
      procedure PostHangupCall;
    end;

    TComm = class( TComponent )
    private
      { Private declarations }
      ReadThread:         TReadThread;
      WriteThread:        TWriteThread;
      hCommFile:          THandle;
      hCloseEvent:        THandle;
      FHWnd:              THandle;
      FSendDataEmpty:     Boolean;            // True if send buffer become empty

      FCommName:          String;
      FBaudRate:          DWORD;
      FParityCheck:       Boolean;
      FOutx_CtsFlow:      Boolean;
      FOutx_DsrFlow:      Boolean;
      FDtrControl:        TDtrControl;
      FDsrSensitivity:    Boolean;
      FTxContinueOnXoff:  Boolean;
      FOutx_XonXoffFlow:  Boolean;
      FInx_XonXoffFlow:   Boolean;
      FReplaceWhenParityError:    Boolean;
      FIgnoreNullChar:    Boolean;
      FRtsControl:        TRtsControl;
      FXonLimit:          WORD;
      FXoffLimit:         WORD;
      FByteSize:          TByteSize;
      FParity:            TParity;
      FStopBits:          TStopBits;
      FXonChar:           AnsiChar;
      FXoffChar:          AnsiChar;
      FReplacedChar:      AnsiChar;

      FReadIntervalTimeout: DWORD;
      FReadTotalTimeoutMultiplier: DWORD;
      FReadTotalTimeoutConstant: DWORD;
      FWriteTotalTimeoutMultiplier: DWORD;
      FWriteTotalTimeoutConstant: DWORD;
      FOnReceiveData:     TReceiveDataEvent;
      FOnRequestHangup:   TNotifyEvent;
      FOnReceiveError:    TReceiveErrorEvent;
      FOnModemStateChange:TModemStateChangeEvent;
      FOnSendDataEmpty: TSendDataEmptyEvent;

      procedure SetBaudRate( Rate : DWORD );
      procedure SetParityCheck( b : Boolean );
      procedure SetOutx_CtsFlow( b : Boolean );
      procedure SetOutx_DsrFlow( b : Boolean );
      procedure SetDtrControl( c : TDtrControl );
      procedure SetDsrSensitivity( b : Boolean );
      procedure SetTxContinueOnXoff( b : Boolean );
      procedure SetOutx_XonXoffFlow( b : Boolean );
      procedure SetInx_XonXoffFlow( b : Boolean );
      procedure SetReplaceWhenParityError( b : Boolean );
      procedure SetIgnoreNullChar( b : Boolean );
      procedure SetRtsControl( c : TRtsControl );
      procedure SetXonLimit( Limit : WORD );
      procedure SetXoffLimit( Limit : WORD );
      procedure SetByteSize( Size : TByteSize );
      procedure SetParity( p : TParity );
      procedure SetStopBits( Bits : TStopBits );
      procedure SetXonChar( c : AnsiChar );
      procedure SetXoffChar( c : AnsiChar );
      procedure SetReplacedChar( c : AnsiChar );

      procedure SetReadIntervalTimeout( v : DWORD );
      procedure SetReadTotalTimeoutMultiplier( v : DWORD );
      procedure SetReadTotalTimeoutConstant( v : DWORD );
      procedure SetWriteTotalTimeoutMultiplier( v : DWORD );
      procedure SetWriteTotalTimeoutConstant( v : DWORD );

      procedure CommWndProc( var msg: TMessage );
      procedure _SetCommState;
      procedure _SetCommTimeout;
    protected
      { Protected declarations }
      procedure CloseReadThread;
      procedure CloseWriteThread;
      procedure ReceiveData(Buffer: PChar; BufferLength: Word);
      procedure ReceiveError( EvtMask : DWORD );
      procedure ModemStateChange( ModemEvent : DWORD );
      procedure RequestHangup;
      procedure _SendDataEmpty;
    public
      { Public declarations }
      property Handle: THandle read hCommFile;
      property SendDataEmpty : Boolean read FSendDataEmpty;
      constructor Create( AOwner: TComponent ); override;
      destructor Destroy; override;
      procedure StartComm;
      procedure StopComm;
      function WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
      function GetModemState : DWORD;
    published
      { Published declarations }
      property CommName: String read FCommName write FCommName;
      property BaudRate: DWORD read FBaudRate write SetBaudRate;
      property ParityCheck: Boolean read FParityCheck write SetParityCheck;
      property Outx_CtsFlow: Boolean read FOutx_CtsFlow write SetOutx_CtsFlow;
      property Outx_DsrFlow: Boolean read FOutx_DsrFlow write SetOutx_DsrFlow;
      property DtrControl: TDtrControl read FDtrControl write SetDtrControl;
      property DsrSensitivity: Boolean read FDsrSensitivity write SetDsrSensitivity;
      property TxContinueOnXoff: Boolean read FTxContinueOnXoff write SetTxContinueOnXoff;
      property Outx_XonXoffFlow: Boolean read FOutx_XonXoffFlow write SetOutx_XonXoffFlow;
      property Inx_XonXoffFlow: Boolean read FInx_XonXoffFlow write SetInx_XonXoffFlow;
      property ReplaceWhenParityError: Boolean read FReplaceWhenParityError write SetReplaceWhenParityError;
      property IgnoreNullChar: Boolean read FIgnoreNullChar write SetIgnoreNullChar;
      property RtsControl: TRtsControl read FRtsControl write SetRtsControl;
      property XonLimit: WORD read FXonLimit write SetXonLimit;
      property XoffLimit: WORD read FXoffLimit write SetXoffLimit;
      property ByteSize: TByteSize read FByteSize write SetByteSize;
      property Parity: TParity read FParity write FParity;
      property StopBits: TStopBits read FStopBits write SetStopBits;
      property XonChar: AnsiChar read FXonChar write SetXonChar;
      property XoffChar: AnsiChar read FXoffChar write SetXoffChar;
      property ReplacedChar: AnsiChar read FReplacedChar write SetReplacedChar;

      property ReadIntervalTimeout: DWORD         read FReadIntervalTimeout         write SetReadIntervalTimeout;
      property ReadTotalTimeoutMultiplier: DWORD  read FReadTotalTimeoutMultiplier  write SetReadTotalTimeoutMultiplier;
      property ReadTotalTimeoutConstant: DWORD    read FReadTotalTimeoutConstant    write SetReadTotalTimeoutConstant;
      property WriteTotalTimeoutMultiplier: DWORD read FWriteTotalTimeoutMultiplier write SetWriteTotalTimeoutMultiplier;
      property WriteTotalTimeoutConstant: DWORD   read FWriteTotalTimeoutConstant   write SetWriteTotalTimeoutConstant;

      property OnReceiveData: TReceiveDataEvent
               read FOnReceiveData write FOnReceiveData;
      property OnReceiveError: TReceiveErrorEvent
               read FOnReceiveError write FOnReceiveError;
      property OnModemStateChange: TModemStateChangeEvent
               read FOnModemStateChange write FOnModemStateChange;
      property OnRequestHangup: TNotifyEvent
               read FOnRequestHangup write FOnRequestHangup;
      property OnSendDataEmpty: TSendDataEmptyEvent
               read FOnSendDataEmpty write FOnSendDataEmpty;
    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;

procedure Register;

implementation

(******************************************************************************)
//   TComm PUBLIC METHODS
(******************************************************************************)

constructor TComm.Create( AOwner: TComponent );
begin
     inherited Create( AOwner );

     ReadThread := nil;
     WriteThread := nil;
     hCommFile := 0;
     hCloseEvent := 0;
     FSendDataEmpty := True;

     FCommName := 'COM2';
     FBaudRate := 9600;
     FParityCheck := False;
     FOutx_CtsFlow := False;
     FOutx_DsrFlow := False;
     FDtrControl := DtrEnable;
     FDsrSensitivity := False;
     FTxContinueOnXoff := True;
     FOutx_XonXoffFlow := True;
     FInx_XonXoffFlow := True;
     FReplaceWhenParityError := False;
     FIgnoreNullChar := False;
     FRtsControl := RtsEnable;
     FXonLimit := 500;
     FXoffLimit := 500;
     FByteSize := _8;
     FParity := None;
     FStopBits := _1;
     FXonChar := chr($11);      // Ctrl-Q
     FXoffChar := chr($13);     // Ctrl-S
     FReplacedChar := chr(0);
     FReadIntervalTimeout         := 100;
     FReadTotalTimeoutMultiplier  := 0;
     FReadTotalTimeoutConstant    := 0;
     FWriteTotalTimeoutMultiplier := 0;
     FWriteTotalTimeoutConstant   := 0;

     if not (csDesigning in ComponentState) then
        FHWnd := AllocateHWnd(CommWndProc)
end;

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

//
//  FUNCTION: StartComm
//
//  PURPOSE: Starts communications over the comm port.
//
//  PARAMETERS:
//    hNewCommFile - This is the COMM File handle to communicate with.
//                   This handle is obtained from TAPI.
//
//  Output:
//    Successful: Startup the communications.
//    Failure: Raise a exception
//
//  COMMENTS:
//
//    StartComm makes sure there isn't communication in progress already,
//    creates a Comm file, and creates the read and write threads.  It
//    also configures the hNewCommFile for the appropriate COMM settings.
//
//    If StartComm fails for any reason, it's up to the calling application
//    to close the Comm file handle.
//
//
procedure TComm.StartComm;
var
   hNewCommFile:   THandle;
begin
     // Are we already doing comm?
     if (hCommFile <> 0) then
        raise ECommsError.Create( 'This serial port already opened' );

     hNewCommFile := CreateFile( PChar(FCommName),
                                 GENERIC_READ or GENERIC_WRITE,
                                 0, {not shared}
                                 nil, {no security ??}
                                 OPEN_EXISTING,
                                 FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED,
                                 0 {template} );

     if hNewCommFile = INVALID_HANDLE_VALUE then
        raise ECommsError.Create( 'Error opening serial port' );

     // Is this a valid comm handle?
     if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then
     begin
          CloseHandle( hNewCommFile );
          raise ECommsError.Create( 'File handle is not a comm handle ' );
     end;

     if not SetupComm( hNewCommFile, 4096, 4096 ) then
     begin
          CloseHandle( hCommFile );
          raise ECommsError.Create( 'Cannot setup comm buffer' );
     end;

     // It is ok to continue.

     hCommFile := hNewCommFile;

     // purge any information in the buffer

     PurgeComm( hCommFile, PURGE_TXABORT or PURGE_RXABORT or
                           PURGE_TXCLEAR or PURGE_RXCLEAR ) ;
     FSendDataEmpty := True;

     // Setting the time-out value
     _SetCommTimeout;

     // Querying then setting the comm port configurations.
     _SetCommState;

     // Create the event that will signal the threads to close.
     hCloseEvent := CreateEvent( nil, True, False, nil );

     if hCloseEvent = 0 then
     begin
          CloseHandle( hCommFile );
          hCommFile := 0;
          raise ECommsError.Create( 'Unable to create event' )
     end;

     // Create the Read thread.
     try
        ReadThread := TReadThread.Create( True {suspended} );
     except
           ReadThread := nil;
           CloseHandle( hCloseEvent );
           CloseHandle( hCommFile );
           hCommFile := 0;
           raise ECommsError.Create( 'Unable to create read thread' )
     end;
     ReadThread.hCommFile := hCommFile;
     ReadThread.hCloseEvent := hCloseEvent;
     ReadThread.hComm32Window := FHWnd;

     // Comm threads should have a higher base priority than the UI thread.
     // If they don't, then any temporary priority boost the UI thread gains
     // could cause the COMM threads to loose data.
     ReadThread.Priority := tpHighest;

     // Create the Write thread.
     try
        WriteThread := TWriteThread.Create( True {suspended} );
     except
           CloseReadThread;
           WriteThread := nil;
           CloseHandle( hCloseEvent );
           CloseHandle( hCommFile );
           hCommFile := 0;
           raise ECommsError.Create( 'Unable to create write thread' )
     end;
     WriteThread.hCommFile := hCommFile;
     WriteThread.hCloseEvent := hCloseEvent;
     WriteThread.hComm32Window := FHWnd;
     WriteThread.pFSendDataEmpty := @FSendDataEmpty;

     WriteThread.Priority := tpHigher;

     ReadThread.Resume;
     WriteThread.Resume

     // Everything was created ok.  Ready to go!
end; {TComm.StartComm}

//
//  FUNCTION: StopComm
//
//  PURPOSE: Stop and end all communication threads.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Tries to gracefully signal all communication threads to
//    close, but terminates them if it has to.
//
//
procedure TComm.StopComm;
begin
     // No need to continue if we're not communicating.
     if hCommFile = 0 then
        Exit;

     // Close the threads.
     CloseReadThread;
     CloseWriteThread;

     // Not needed anymore.
     CloseHandle( hCloseEvent );

     // Now close the comm port handle.
     CloseHandle( hCommFile );
     hCommFile := 0
end; {TComm.StopComm}

//
//  FUNCTION: WriteCommData(PChar, Word)
//
//  PURPOSE: Send a String to the Write Thread to be written to the Comm.
//
//  PARAMETERS:
//    pszStringToWrite     - String to Write to Comm port.
//    nSizeofStringToWrite - length of pszStringToWrite.
//
//  RETURN VALUE:
//    Returns TRUE if the PostMessage is successful.
//    Returns FALSE if PostMessage fails or Write thread doesn't exist.
//
//  COMMENTS:
//
//    This is a wrapper function so that other modules don't care that
//    Comm writing is done via PostMessage to a Write thread.  Note that
//    using PostMessage speeds up response to the UI (very little delay to
//    'write' a string) and provides a natural buffer if the comm is slow
//    (ie: the messages just pile up in the message queue).
//
//    Note that it is assumed that pszStringToWrite is allocated with
//    LocalAlloc, and that if WriteCommData succeeds, its the job of the
//    Write thread to LocalFree it.  If WriteCommData fails, then its
//    the job of the calling function to free the string.
//
//
function TComm.WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
var
   Buffer: Pointer;
begin
     if (WriteThread <> nil) and (dwSizeofDataToWrite <> 0) then
     begin
          Buffer := Pointer(LocalAlloc( LPTR, dwSizeofDataToWrite+1 ));
          Move( pDataToWrite^, Buffer^, dwSizeofDataToWrite );