serialng.~pas

用SerialNG组件写的一个串口通信程序,在delphi7下测试通过

      if fActive then
        begin
          if not SetupComm(hCommPort,fRxQueueSize,fTxQueueSize) then
            ProcessError(0111,GetLastError,'Error setup Queuesize',enError);
          SetupDCB;
          SetSignalDTR(dflt_DTRState);
          SetSignalRTS(dflt_RTSState);
          EnableEvents;
        end
      else
        ProcessError(0112,GetLastError,'Error reopening Port',enError);
    end;
end;

// Internal method to enable all Events
procedure TSerialPortNG.EnableEvents;
begin
  if not SetCommMask(hCommPort, EV_BREAK or EV_CTS or EV_DSR or EV_ERR or EV_RING or EV_RLSD or EV_RXCHAR or EV_RXFLAG or EV_TXEMPTY) then
    ProcessError(0201,GetLastError,'Error activating CommEventMask',enError);
end;

// Public method to cancel and  flush the receive buffer.
procedure TSerialPortNG.ClearRxDQueue;
begin
  if fActive then
    if not PurgeComm(hCommPort,  PURGE_RXABORT or PURGE_RXCLEAR) then
      ProcessError(0301,GetLastError,'Error clearing RxD Queue',enError);
end;

// Public method to cancel and flush the transmit buffer.
procedure TSerialPortNG.ClearTxDQueue;
begin
  if fActive then
    if not PurgeComm(hCommPort,  PURGE_TXABORT or PURGE_TXCLEAR) then
      ProcessError(0401,GetLastError,'Error clearing TxD Queue',enError);
end;

// Public method to Play with the RTS Line
// It is an Error to work on this Line while in the Flowmode bmfOutxCtsFlow is set!
procedure TSerialPortNG.SetSignalRTS(State : Boolean);
begin
  if fActive then
    begin
      if State then
        begin
          if not EscapeCommFunction(hCommPort,SETRTS) then
            ProcessError(0501,GetLastError,'Error setting RTS',enError)
        end
      else
        begin
          if not EscapeCommFunction(hCommPort,CLRRTS) then
            ProcessError(0502,GetLastError,'Error clearing RTS',enError)
        end;
      fRTSState := State;
    end;
end;

// Public method to Play with the DTR Line
// It is an Error to work on this Line while in the Flowmode bmfOutxDtrFlow is set!
procedure TSerialPortNG.SetSignalDTR(State : Boolean);
begin
  if fActive then
    begin
      if State then
        begin
          if not EscapeCommFunction(hCommPort,SETDTR) then
            ProcessError(0601,GetLastError,'Error setting DTR',enError)
        end
      else
        begin
          if not EscapeCommFunction(hCommPort,CLRDTR) then
            ProcessError(0602,GetLastError,'Error clearing DTR',enError)
        end;
      fDTRState := State;
    end;
end;

// Public method to set the break State
procedure TSerialPortNG.SetSignalBREAK(State : Boolean);
begin
  if fActive then
    begin
      if State then
        begin
          if not SetCommBreak(hCommPort) then
            ProcessError(0701,GetLastError,'Error setting BREAK State',enError)
        end
      else
        begin
          if not ClearCommBreak(hCommPort) then
            ProcessError(0702,GetLastError,'Error clearing BREAK State',enError)
        end;
      fBREAKState := State;
    end;
end;

// Initialize the device control block.
procedure TSerialPortNG.SetupDCB;
var
  MyDCB : TDCB;
  MyCommTimeouts : TCommTimeouts;
//  SDCB : array[0..79] of Char;
begin
  // The GetCommState function fills in a
  // device-control block (a DCB structure)
  // with the current control settings for
  // a specified communications device.
  // (Win32 Developers Reference)
  // Get a default fill of the DCB.
  if not GetCommState(hCommPort, MyDCB) then
    begin
      ProcessError(0801,GetLastError,'Error getting DCB from CommState',enError);
      Exit;
    end;

  MyDCB.BaudRate := fBaudRate;
  MyDCB.Flags := bmfBinary; //Must be set under Win32
  if fParityType <> NOPARITY then // If a ParityType is selceted, set Paritybit automatic
    MyDCB.Flags := MyDCB.Flags or bmfParity;
  MyDCB.Parity := fParityType;
  if fParityErrorReplacement then
    MyDCB.Flags := MyDCB.Flags or bmfErrorChar;
  MyDCB.Flags := MyDCB.Flags or fFlowControl;
  if fStripNullChars then
    MyDCB.Flags := MyDCB.Flags or bmfNull;
  MyDCB.ErrorChar := fParityErrorChar;
  MyDCB.EvtChar := fEventChar;
  MyDCB.StopBits := fStopBits;
  MyDCB.ByteSize := fDataBits;
  MyDCB.XONChar := fXONChar;
  MyDCB.XOFFChar := fXOFFChar;
  MyDCB.XONLim := fRxQueueSize * fXONLimDiv div 100; // Send XOn if e.g fXONLimDiv = 33 -> 33% full
  MyDCB.XOFFLim := fRxQueueSize * fXOFFLimDiv div 100;  // Send XOff if e.g fXOffLimDiv = 33 -> 100%-33%=67% Percent full
  MyDCB.EOFChar := #0; //Ignored under Win32

  // The SetCommTimeouts function sets
  // the time-out parameters for all
  // read and write operations on a
  // specified communications device.
  // (Win32 Developers Reference)
  // The GetCommTimeouts function retrieves
  // the time-out parameters for all read
  // and write operations on a specified
  // communications device.
  GetCommTimeouts(hCommPort, MyCommTimeouts);
  //Read Timeouts are disabled here, because they realized manually in the WorkThread
  MycommTimeouts.ReadIntervalTimeout := MAXDWORD;
  MycommTimeouts.ReadTotalTimeoutMultiplier := 0;
  MycommTimeouts.ReadTotalTimeoutConstant := 0;
  //Write Timeouts disable here
  MycommTimeouts.WriteTotalTimeoutMultiplier := 0;
  MycommTimeouts.WriteTotalTimeoutConstant := 0;
  if not SetCommTimeouts(hCommPort, MyCommTimeouts) then
      ProcessError(0802,GetLastError,'Error setting CommTimeout',enError);
  if not SetCommState(hCommPort, MyDCB) then
    ProcessError(0802,GetLastError,'Error setting CommState, 87 indicate that Parms are incorrect',enError);
end;

// Public Send data method.
procedure TSerialPortNG.SendData(Data : Pointer; Size : DWord);
var MyCommTimeOuts : TCommTimeOuts;
begin
  if fSendInProgress then
    begin
      ProcessError(0901,0,'Msg, dont enter SendData while SendInProgress is set',enMsg);
      Exit;
    end
  else
    begin
      GetCommTimeouts(hCommPort, MyCommTimeouts);
      //Read Timeouts are disabled
      MycommTimeouts.ReadIntervalTimeout := MAXDWORD;
      MycommTimeouts.ReadTotalTimeoutMultiplier := 0;
      MycommTimeouts.ReadTotalTimeoutConstant := 0;
      //Write Timeouts calculated from the settings
      MycommTimeouts.WriteTotalTimeoutMultiplier := 0;
      MycommTimeouts.WriteTotalTimeoutConstant := ((fWTOCharDelayTime*Size) div 1000) + fWTOExtraDelayTime;
      if not SetCommTimeouts(hCommPort, MyCommTimeouts) then
          ProcessError(0902,GetLastError,'Error setting CommTimeout',enError);
      BytesToWrite := Size;
      if not WriteFile(hCommPort,
                Data^,
                Size,
                fWrittenBytes,
                @WriteOverlapped) then
         begin
           LastErr := GetLastError;
           if LastErr <> ERROR_IO_PENDING then
             begin
               ProcessError(0903,LastErr,'Error writing Data',enError);
               ResetOverlapped(WriteOverlapped);
               fSendInProgress := False;
             end
           else
             begin
               WriteStartTime := GetTickCount;
               fSendInProgress := True;
             end;
         end
       else  // Write was done immidiatly
         begin
           if Assigned(fOnWriteDone) then
             fOnWriteDone(Self);
         end;
     end;
end;

// Public SendString Method
procedure TSerialPortNG.SendString(S : String);
begin
  if Length(S) > 0 then
    SendData(@S[1], Length(S));
end;

// Public NextClusterSize Method
// Return the Number of Databytes
// 0..MAXINT indicates that a Cluster is available, 0 = No Bytes, but an Error code
// -1 not Cluster is available
function TSerialPortNG.NextClusterSize : Integer;
begin
  EnterCriticalSection(CriticalSection);
  try
    if RxDClusterList.Count > 0 then
      if RxDClusterList.Items[0] = Nil then
          RxDClusterList.Pack;
    if RxDClusterList.Count > 0 then
      NextClusterSize := TSerialCluster(RxDClusterList.Items[0]).GetSize
    else
      NextClusterSize := -1;
  finally
    LeaveCriticalSection(CriticalSection);
  end;
end;

// Public NextClusterCCError Method
// Returns the ErrorCode of the Next Cluster
// Returns MAXDWORD if no Cluster in List
function TSerialPortNG.NextClusterCCError : DWord;
begin
  EnterCriticalSection(CriticalSection);
  try
    if RxDClusterList.Count > 0 then
      if RxDClusterList.Items[0] = Nil then
          RxDClusterList.Pack;
    if RxDClusterList.Count > 0 then
      NextClusterCCError := TSerialCluster(RxDClusterList.Items[0]).GetCCError
    else
      NextClusterCCError := MAXDWORD;
  finally
    LeaveCriticalSection(CriticalSection);
  end;
end;

// Public Method to read and remove the next Cluster from the List
// If no Cluster is avail the Method retuns NIL
// Else, You have to deal with the Pointer, and Free him self
function TSerialPortNG.ReadNextCluster(var ClusterSize : Integer; var CCError : DWord) : Pointer;
var DataBuffer : Pointer;
begin
  EnterCriticalSection(CriticalSection);
  try
    if RxDClusterList.Count > 0 then
      if RxDClusterList.Items[0] = Nil then
          RxDClusterList.Pack;
    if RxDClusterList.Count > 0 then
      begin
        CCError := TSerialCluster(RxDClusterList.Items[0]).GetCCError;
        ClusterSize := TSerialCluster(RxDClusterList.Items[0]).GetSize;
        GetMem(DataBuffer, ClusterSize);
        TSerialCluster(RxDClusterList.Items[0]).GetData(DataBuffer);
        TSerialCluster(RxDClusterList.Items[0]).Free;
        RxDClusterList.Delete(0);
        ReadNextCluster := DataBuffer;
      end
    else
      begin
        ClusterSize := -1;
        CCError := MAXDWORD;
        ReadNextCluster := Nil;
      end;
  finally
    LeaveCriticalSection(CriticalSection);
  end;
end;

// Public Method to read and remove the next Cluster from the List
// The Cluster is moved into a String
function TSerialPortNG.ReadNextClusterAsString : String;
begin
  EnterCriticalSection(CriticalSection);
  try
    if RxDClusterList.Count > 0 then
      if RxDClusterList.Items[0] = Nil then
          RxDClusterList.Pack;
    if RxDClusterList.Count > 0 then
      begin
        ReadNextClusterAsString := TSerialCluster(RxDClusterList.Items[0]).GetDataAsString;
        TSerialCluster(RxDClusterList.Items[0]).Free;
        RxDClusterList.Delete(0);
      end
    else
      ReadNextClusterAsString := '';
  finally
    LeaveCriticalSection(CriticalSection);
  end;
end;

// Public Method to read and remove the next Cluster from the List
// The Cluster is moved into "Dest". "Dest" should Point to enough Space to avoid
// Exception Errors
function TSerialPortNG.ReadNextClusterAsPChar(Dest : PChar) : PChar;
begin
  EnterCriticalSection(CriticalSection);
  try
    if Dest <> Nil then
      begin
        if RxDClusterList.Count > 0 then
          if RxDClusterList.Items[0] = Nil then
              RxDClusterList.Pack;
        if RxDClusterList.Count > 0 then
          begin
            ReadNextClusterAsPChar := TSerialCluster(RxDClusterList.Items[0]).GetDataAsPChar(Dest);
            TSerialCluster(RxDClusterList.Items[0]).Free;
            RxDClusterList.Delete(0);
          end
        else
          ReadNextClusterAsPChar := Nil;
      end
    else
      ReadNextClusterAsPChar := Nil;
  finally
    LeaveCriticalSection(CriticalSection);
  end;
end;

// Private Method