spcomm.pas

PC机控制系统程序

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' );
    raise ECommsError.Create('该串口已经被打开了');

  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' );
    raise ECommsError.Create('打开串口错误');

     // 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 ' )
    raise ECommsError.Create('文件句柄不是串口类型')
  end;

  if not SetupComm(hNewCommFile, 4096, 4096) then
  begin
    CloseHandle(hCommFile);
//          raise ECommsError.Create( 'Cannot setup comm buffer' )
    raise ECommsError.Create('没有足够的内存配置串口通讯缓存')
  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' )
    raise ECommsError.Create('不能创建事件')
  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' )
    raise ECommsError.Create('创建读线程失败')
  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' )
    raise ECommsError.Create('创建写线程失败')
  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.