spcomm.pas

来自「群星医药系统源码」· PAS 代码 · 共 1,932 行 · 第 1/4 页

unit Spcomm;
//
//
// 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 SetParity; //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)