spcomm.pas

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

//
//  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);
    if PostThreadMessage(WriteThread.ThreadID, PWM_COMMWRITE,
      WPARAM(dwSizeofDataToWrite), LPARAM(Buffer)) then
    begin
      FSendDataEmpty := False;
      Result := True;
      Exit;
    end
  end;

  Result := False
end; {TComm.WriteCommData}

//
//  FUNCTION: GetModemState
//
//  PURPOSE: Read the state of modem input pin right now
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//
//    A DWORD variable containing one or more of following codes:
//
//    Value      Meaning
//    ----------  -----------------------------------------------------------
//    MS_CTS_ON  The CTS (clear-to-send) signal is on.
//    MS_DSR_ON  The DSR (data-set-ready) signal is on.
//    MS_RING_ON  The ring indicator signal is on.
//    MS_RLSD_ON  The RLSD (receive-line-signal-detect) signal is on.
//
//    If this comm have bad handle or not yet opened, the return value is 0
//
//  COMMENTS:
//
//    This member function calls GetCommModemStatus and return its value.
//    Before calling this member function, you must have a successful
//    'StartOpen' call.
//
//

function TComm.GetModemState: DWORD;
var
  dwModemState: DWORD;
begin
  if not GetCommModemStatus(hCommFile, dwModemState) then
    Result := 0
  else
    Result := dwModemState
end;


(******************************************************************************)
//  TComm PROTECTED METHODS
(******************************************************************************)

//
//  FUNCTION: CloseReadThread
//
//  PURPOSE: Close the Read Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the Read thread by signaling the CloseEvent.
//    Purges any outstanding reads on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//

procedure TComm.CloseReadThread;
begin
    // If it exists...
  if ReadThread <> nil then
  begin
          // Signal the event to close the worker threads.
    SetEvent(hCloseEvent);

          // Purge all outstanding reads
    PurgeComm(hCommFile, PURGE_RXABORT + PURGE_RXCLEAR);

          // Wait 10 seconds for it to exit.  Shouldn't happen.
    if (WaitForSingleObject(ReadThread.Handle, 10000) = WAIT_TIMEOUT) then
      ReadThread.Terminate;
    ReadThread.Free;
    ReadThread := nil
  end
end; {TComm.CloseReadThread}

//
//  FUNCTION: CloseWriteThread
//
//  PURPOSE: Closes the Write Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the write thread by signaling the CloseEvent.
//    Purges any outstanding writes on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//

procedure TComm.CloseWriteThread;
begin
    // If it exists...
  if WriteThread <> nil then
  begin
          // Signal the event to close the worker threads.
    SetEvent(hCloseEvent);

          // Purge all outstanding writes.
    PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);
    FSendDataEmpty := True;

          // Wait 10 seconds for it to exit.  Shouldn't happen.
    if WaitForSingleObject(WriteThread.Handle, 10000) = WAIT_TIMEOUT then
      WriteThread.Terminate;
    WriteThread.Free;
    WriteThread := nil
  end
end; {TComm.CloseWriteThread}

procedure TComm.ReceiveData(Buffer: PChar; BufferLength: Word);
begin
  if Assigned(FOnReceiveData) then
    FOnReceiveData(self, Buffer, BufferLength)
end;

procedure TComm.ReceiveError(EvtMask: DWORD);
begin
  if Assigned(FOnReceiveError) then
    FOnReceiveError(self, EvtMask)
end;

procedure TComm.ModemStateChange(ModemEvent: DWORD);
begin
  if Assigned(FOnModemStateChange) then
    FOnModemStateChange(self, ModemEvent)
end;

procedure TComm.RequestHangup;
begin
  if Assigned(FOnRequestHangup) then
    FOnRequestHangup(Self)
end;

procedure TComm._SendDataEmpty;
begin
  if Assigned(FOnSendDataEmpty) then
    FOnSendDataEmpty(self)
end;

(******************************************************************************)
//  TComm PRIVATE METHODS
(******************************************************************************)

procedure TComm.CommWndProc(var msg: TMessage);
begin
  case msg.msg of
    PWM_GOTCOMMDATA:
      begin
        ReceiveData(PChar(msg.LParam), msg.WParam);
        LocalFree(msg.LParam)
      end;
    PWM_RECEIVEERROR: ReceiveError(msg.LParam);
    PWM_MODEMSTATECHANGE: ModemStateChange(msg.LParam);
    PWM_REQUESTHANGUP: RequestHangup;
    PWM_SENDDATAEMPTY: _SendDataEmpty
  end
end;

procedure TComm._SetCommState;
var
  dcb: Tdcb;
  commprop: TCommProp;
  fdwEvtMask: DWORD;
begin
    // Configure the comm settings.
    // NOTE: Most Comm settings can be set through TAPI, but this means that
    //      the CommFile will have to be passed to this component.

  GetCommState(hCommFile, dcb);
  GetCommProperties(hCommFile, commprop);
  GetCommMask(hCommFile, fdwEvtMask);

    // fAbortOnError is the only DCB dependancy in TapiComm.
    // Can't guarentee that the SP will set this to what we expect.
    {dcb.fAbortOnError := False; NOT VALID}

  dcb.BaudRate := FBaudRate;

  dcb.Flags := 1; // Enable fBinary

  if FParityCheck then
    dcb.Flags := dcb.Flags or 2; // Enable parity check

    // setup hardware flow control

  if FOutx_CtsFlow then
    dcb.Flags := dcb.Flags or 4;

  if FOutx_DsrFlow then
    dcb.Flags := dcb.Flags or 8;

  if FDtrControl = DtrEnable then
    dcb.Flags := dcb.Flags or $10
  else if FDtrControl = DtrHandshake then
    dcb.Flags := dcb.Flags or $20;

  if FDsrSensitivity then
    dcb.Flags := dcb.Flags or $40;

  if FTxContinueOnXoff then
    dcb.Flags := dcb.Flags or $80;

  if FOutx_XonXoffFlow then
    dcb.Flags := dcb.Flags or $100;

  if FInx_XonXoffFlow then
    dcb.Flags := dcb.Flags or $200;

  if FReplaceWhenParityError then
    dcb.Flags := dcb.Flags or $400;

  if FIgnoreNullChar then
    dcb.Flags := dcb.Flags or $800;

  if FRtsControl = RtsEnable then
    dcb.Flags := dcb.Flags or $1000
  else if FRtsControl = RtsHandshake then
    dcb.Flags := dcb.Flags or $2000
  else if FRtsControl = RtsTransmissionAvailable then
    dcb.Flags := dcb.Flags or $3000;

  dcb.XonLim := FXonLimit;
  dcb.XoffLim := FXoffLimit;

  dcb.ByteSize := Ord(FByteSize) + 5;
  dcb.Parity := Ord(FParity);
  dcb.StopBits := Ord(FStopBits);

  dcb.XonChar := FXonChar;
  dcb.XoffChar := FXoffChar;

  dcb.ErrorChar := FReplacedChar;

  SetCommState(hCommFile, dcb)
end;

procedure TComm._SetCommTimeout;
var
  commtimeouts: TCommTimeouts;
begin
  GetCommTimeouts(hCommFile, commtimeouts);

    // The CommTimeout numbers will very likely change if you are
    // coding to meet some kind of specification where
    // you need to reply within a certain amount of time after
    // recieving the last byte.  However,  If 1/4th of a second
    // goes by between recieving two characters, its a good
    // indication that the transmitting end has finished, even
    // assuming a 1200 baud modem.

  commtimeouts.ReadIntervalTimeout := FReadIntervalTimeout;
  commtimeouts.ReadTotalTimeoutMultiplier := FReadTotalTimeoutMultiplier;
  commtimeouts.ReadTotalTimeoutConstant := FReadTotalTimeoutConstant;
  commtimeouts.WriteTotalTimeoutMultiplier := FWriteTotalTimeoutMultiplier;
  commtimeouts.WriteTotalTimeoutConstant := FWriteTotalTimeoutConstant;

  SetCommTimeouts(hCommFile, commtimeouts);
end;

procedure TComm.SetBaudRate(Rate: DWORD);
begin
  if Rate = FBaudRate then
    Exit;

  FBaudRate := Rate;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetParityCheck(b: Boolean);
begin
  if b = FParityCheck then
    Exit;

  FParityCheck := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_CtsFlow(b: Boolean);
begin
  if b = FOutx_CtsFlow then
    Exit;

  FOutx_CtsFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_DsrFlow(b: Boolean);
begin
  if b = FOutx_DsrFlow then
    Exit;

  FOutx_DsrFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetDtrControl(c: TDtrControl);
begin
  if c = FDtrControl then
    Exit;

  FDtrControl := c;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetDsrSensitivity(b: Boolean);
begin
  if b = FDsrSensitivity then
    Exit;

  FDsrSensitivity := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetTxContinueOnXoff(b: Boolean);
begin
  if b = FTxContinueOnXoff then
    Exit;

  FTxContinueOnXoff := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_XonXoffFlow(b: Boolean);
begin
  if b = FOutx_XonXoffFlow then
    Exit;

  FOutx_XonXoffFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetInx_XonXoffFlow(b: Boolean);
begin
  if b = FInx_XonXoffFlow then
    Exit;

  FInx_XonXoffFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetReplaceWhenParityError(b: Boolean);
begin
  if b = FReplaceWhenParityError then
    Exit;

  FReplaceWhenParityError := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetIgnoreNullChar(b: Boolean);
begin
  if b = FIgnoreNullChar then
    Exit;

  FIgnoreNullChar := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetRtsControl(c: TRtsControl);
begin
  if c = FRtsControl then
    Exit;

  FRtsControl := c;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetXonLimit(Limit: WORD);
begin
  if Limit = FXonLimit then
    Exit;

  FXonLimit := Limit;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetXoffLimit(Limit: WORD);
begin
  if Limit = FXoffLimit then
    Exit;

  FXoffLimit := Limit;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetByteSize(Size: TByteSize);
begin
  if Size = FByteSize then
    Exit;