xcom.pas

the best serial port component for delphi application. you can send receive serial port datas as

      fTxQueueSize := value;
      if not SetupComm(hCommPort,fRxQueueSize,fTxQueueSize) then
        ProcessError(0102,GetLastError,'Error can not set Quesize',enError);
    end;
end;

procedure TXCom.SetErrorNoise(value : Byte);
begin
  fErrorNoise := value;
end;

procedure TXCom.SetReadRequest(value : Boolean);
begin
  fReadRequest := value;
end;

procedure TXCom.SetActive(NewState : Boolean);
begin
  // You may expect that this function set only the fActive Value
  // This is done by the PortWork procedure, depending from the successful
  // opened Port
  if NewState <> fActive then
    PortWork(NewState);
end;

procedure TXCom.ProcessError(Place, Code : DWord; Msg : String; Noise : Byte);
begin
  if ShutdownInProgress then Exit; // No Messages now the Component is in Destroystate
  if Noise <= fErrorNoise then
    if assigned(fOnProcessError) then
      fOnProcessError(Owner,Place,Code,Msg,Noise);
end;

procedure TXCom.InitOverlapped(var Overlapped : TOverlapped);
begin
  Overlapped.Offset := 0;
  Overlapped.OffsetHigh := 0;
  Overlapped.Internal := 0;
  Overlapped.InternalHigh := 0;
  Overlapped.hEvent := CreateEvent(nil,True,False,'');
  if Overlapped.hEvent = 0 then
    ProcessError(1001,GetLastError,'Error Creating Overlapped Event',enError)
  else if GetLastError = ERROR_ALREADY_EXISTS then
    ProcessError(1002,ERROR_ALREADY_EXISTS,'Error Overlapped Event Exists',enError)
end;

procedure TXCom.ResetOverlapped(var Overlapped : TOverlapped);
begin
  if not ResetEvent(Overlapped.hEvent) then
    ProcessError(1101,GetLastError,'Error resetting Overlapped Event',enError);
end;

procedure TXCom.SetOverlapped(var Overlapped : TOverlapped);
begin
  if not SetEvent(Overlapped.hEvent) then
// EVENT_MODIFY_STATE
    ProcessError(1101,GetLastError,'Error resetting Overlapped Event',enError);
end;


//
// Create method.
constructor TXCom.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  InitializeCriticalSection(CriticalSection); 
  ShutdownInProgress := False;
  hCommPort := INVALID_HANDLE_VALUE;
  Platform := CheckOS(VersionInfo);

  fCommPort := dflt_CommPort;
  fBaudRate := dflt_BaudRate;
  fDeviceAdr:= dflt_DeviceAdr;
  fRCPStx:= dflt_Stx;
  fParityType := dflt_ParityType;
  fStopBits := dflt_StopBits;
  fDataBits := dflt_DataBits;
  fXONChar := dflt_XONChar;
  fXOFFChar := dflt_XOFFChar;
  fXONLimDiv := dflt_XONLimDiv;
  fXOFFLimDiv := dflt_XOFFLimDiv;
  fFlowControl := dflt_FlowControl;
  fRTOCharDelayTime := dflt_RTOCharDelayTime;
  fRTOExtraDelayTime := dflt_RTOExtraDelayTime;
  fWTOCharDelayTime := dflt_WTOCharDelayTime;
  fWTOExtraDelayTime := dflt_WTOExtraDelayTime;
  fXTOAuto := dflt_XTOAuto;
  fClusterSize := dflt_ClusterSize;
  fRxQueueSize := dflt_RxQueueSize;
  fTxQueueSize := dflt_TxQueueSize;
  fErrorNoise := enAll;
  fReadRequest := False;
  fRTSState := dflt_RTSState;
  fDTRState := dflt_DTRState;
  fBREAKState := dflt_BREAKState;
  fOnTxQueueEmptyEvent := Nil;
  fOnBreakEvent := Nil;
  fOnCTSEvent := Nil;
  fOnDSREvent := Nil;
  fOnLineErrorEvent := Nil;
  fOnRingEvent := Nil;
  fOnRLSDEvent := Nil;
  fOnRxCharEvent := Nil;
  fOnRxEventCharEvent := Nil;
  fOnRxClusterEvent := Nil;
  fOnProcessError := Nil;
  fThreadQuietMode := dflt_ThreadQuietMode;
  LastErr := 0;
  RxDClusterList := TList.Create; // Create the List to store the received Clusters
  InitOverlapped(WriteOverlapped);
  InitOverlapped(ReadOverlapped);
  InitOverlapped(StatusOverlapped);
  WorkThread := TWorkThread.Create(Self);
  WorkThread.OnTerminate := WorkThreadDone;
end;

// Destroy method.
destructor TXCom.Destroy;
var i : Integer;
begin
  ShutdownInProgress := True;
  PortWork(False);
  WorkThread.Terminate;
  WaitForThreadNotRunning(10);
  CloseHandle(WriteOverlapped.hEvent);
  CloseHandle(StatusOverlapped.hEvent);
  CloseHandle(ReadOverlapped.hEvent);
  for i := 0 to RxDClusterList.Count-1 do
    begin
      if RxDClusterList.Items[i] <> Nil then
        begin
          TSerialCluster(RxDClusterList.Items[i]).Free;
          RxDClusterList.Items[i] := Nil;
        end;
    end;
  RxDClusterList.Free;
  WorkThread.Free;
  DeleteCriticalSection(CriticalSection);
  inherited Destroy;
end;

procedure TXCom.PortWork(ReOpen : Boolean);
var
  CommPortName : array [0..127] of Char;
begin
  if fActive then // The Port is Open, Close first
    begin
      ProcessError(0100,0,'Msg start deactivating Port',enMsg);
      if not SetCommMask(hCommPort,0) then
        ProcessError(0101,GetLastError,'Error disabling CommEvents',enError);
      fActive := False; // The WorkThread check this Flag
      if not PurgeComm(hCommPort, PURGE_RXABORT or PURGE_RXCLEAR or PURGE_TXABORT or PURGE_TXCLEAR) then
        ProcessError(0102,GetLastError,'Error clearing Queues',enError);
      WaitForThreadNotRunning(15);
      if WorkThreadIsRunning then
        ProcessError(0104,0,'Warning ThreadIsRunning',enWarning);
      SetSignalDTR(False);
      SetSignalRTS(False);
      if not CloseHandle(hCommPort) then
        ProcessError(0103,GetLastError,'Error closing Port',enError);
      hCommPort := INVALID_HANDLE_VALUE;
    end;
// The Port is Closed, the Thread is Idle
  if  ReOpen then
    begin // Reopen the Port with (new) Parms
      ProcessError(0110,0,'Msg start reactivating Port',enMsg);
      hCommPort := CreateFile(StrPCopy(CommPortName,'\\.\'+Copy(fCommPort,1,79)),
            GENERIC_READ OR GENERIC_WRITE,
            0,
            nil,
            OPEN_EXISTING,
            FILE_FLAG_OVERLAPPED,0);
      fActive := (hCommPort <> INVALID_HANDLE_VALUE);
      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 TXCom.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 TXCom.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 TXCom.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 TXCom.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 TXCom.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 TXCom.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 TXCom.SetupDCB;
var
  MyDCB : TDCB;
  MyCommTimeouts : TCommTimeouts;
begin
  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 selected, 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

  GetCommTimeouts(hCommPort, MyCommTimeouts);
  MycommTimeouts.ReadIntervalTimeout := MAXDWORD;
  MycommTimeouts.ReadTotalTimeoutMultiplier := 0;
  MycommTimeouts.ReadTotalTimeoutConstant := 0;
  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 TXCom.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 TXCom.SendString(S : string;L : Integer);
var
I:DWord;
begin
I:=DWord(L);
if L=0 then I:=Length(S) else I:=DWord(L);
  if Length(S) > 0 then
    SendData(@S[1], I);
end;


// Public SendArray Method