spcomm.pas

超市系统开发 超市系统开发 超市系统开发 超市系统开发

unit SPComm;
//
// 这是一个串行端口通讯组件, 供 Delphi 2.0 应用程序使用. 适合用来做工业控制及
// 简单传输. 此组件调用 Win32 API 来达成所需功能, 请见Communications部份。
//
// 此组件参考 David Wann. 所制作的 COMM32.PAS Version 1.0。原始说明如下：
// This Communications Component is implemented using separate Read and Write
// threads. Messages from the threads are posted to the Comm control which is
// an invisible window. To handle data from the comm port, simply
// attach a handler to 'OnReceiveData'. There is no need to free the memory
// buffer passed to this handler. If TAPI is used to open the comm port, some
// changes to this component are needed ('StartComm' currently opens the comm
// port). The 'OnRequestHangup' event is included to assist this.
//
// David Wann
// Stamina Software
// 28/02/96
// [e-mail]
//
//
// 这个组件完全免费, 欢迎拷贝' 修改或做任何其它用途. 除了单独销售此组件.
// This component is totally free(copyleft), you can do anything in any
// purpose EXCEPT SELL IT ALONE.
//
//
// Author?: 小猪工作室 Small-Pig Team         in Taiwan R.O.C.
// Email   : [e-mail]
// Date ? : 1997/5/9
//
// Version 1.01     1996/9/4
//                  - Add setting Parity, Databits, StopBits
//                  - Add setting Flowcontrol:Dtr-Dsr, Cts-Rts, Xon-Xoff
//                  - Add setting Timeout information for read/write
//
// Version 1.02     1996/12/24
//                  - Add Sender parameter to TReceiveDataEvent
//
// Version 2.0      1997/4/15
//                  - Support separatly DTR/DSR and RTS/CTS hardware flow control setting
//                  - Support separatly OutX and InX software flow control setting
//                  - Log file(for debug) may used by many comms at the same time
//                  - Add DSR sensitivity property
//                  - You can set error char. replacement when parity error
//                  - Let XonLim/XoffLim and XonChar/XoffChar setting by yourself
//                  - You may change flow-control when comm is still opened
//                  - Change TComm32 to TComm
//                  - Add OnReceiveError event handler
//                  - Add OnReceiveError event handler when overrun, framing error,
//                    parity error
//                  - Fix some bug
//
// Version 2.01     1997/4/19
//                  - Support some property for modem
//                  - Add OnModemStateChange event hander when RLSD(CD) change state
//
// Version 2.02     1997/4/28
//                  - Bug fix: When receive XOFF character, the system FAULT!!!!
//
// Version 2.5      1997/5/9
//                  - Add OnSendDataEmpty event handler when all data in buffer
//                    are sent(send-buffer become empty) this handler is called.
//                    You may call send data here.
//                  - Change the ModemState parameters in OnModemStateChange
//                    to ModemEvent to indicate what modem event make this call
//                  - Add RING signal detect. When RLSD changed state or
//                    RING signal was detected, OnModemStateChange handler is called
//                  - Change XonLim and XoffLim from 100 to 500
//                  - Remove TWriteThread.WriteData member
//                  - PostHangupCall is re-design for debuging function 
//                  - Add a boolean property SendDataEmpty, True when send buffer
//                    is empty
//

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' );