serialng.pas

RS232 Source using delphi

        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
  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;
end;

// Public NextClusterCCError Method
// Returns the ErrorCode of the Next Cluster
// Returns MAXDWORD if no Cluster in List
function TSerialPortNG.NextClusterCCError : DWord;
begin
  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;
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
  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;
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
  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 := '';
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
  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;
end;

// Private Method
procedure TSerialPortNG.WorkThreadDone(Sender: TObject);
begin
  WorkThreadIsRunning := False;
end;

// Public Method to fit the TimeOut Values to the current Baudrate
// If the Property XTOAuto is true this method will be called from the SetBaud method
procedure TSerialPortNG.XTODefault;
var i : Integer;
    NewXTO : DWord;
begin
  NewXTO := 1100;
  for i := 0 to BaudRateCount-1 do
    begin
      if fBaudRate <= BaudRates[i] then
        NewXTO := XTOCharDelayDef[i];
    end;
  SetRTOCharDelayTime(NewXTO);
  SetWTOCharDelayTime(NewXTO);
end;

// Saves all Setting into the Registry
// e.g. WriteSettings('Software/DomIS','SerialNGAdvDemo')
// will save to HKEY_CURRENT_USER\Software\DomIS\SerialAdvDemo
procedure TSerialPortNG.WriteSettings(Regkey, RegSubKey : String);

var FIniFile : TRegIniFile;
begin
  FIniFile := TRegIniFile.Create(RegKey);
  try
    try
    with FIniFile do
      begin
        WriteString(RegSubKey, 'CommPort', fCommPort);
        WriteString(RegSubKey, 'BaudRate', IntToStr(fBaudRate));
        WriteString(RegSubKey, 'ParityType', IntToStr(fParityType));
        WriteString(RegSubKey, 'ParityErrorChar', fParityErrorChar);
        WriteBool  (RegSubKey, 'ParityErrorReplacement', fParityErrorReplacement);
        WriteString(RegSubKey, 'StopBits', IntToStr(fStopBits));
        WriteString(RegSubKey, 'DataBits', IntToStr(fDataBits));
        WriteString(RegSubKey, 'XONChar', fXONChar);
        WriteString(RegSubKey, 'XOFFChar', fXOFFChar);
        WriteString(RegSubKey, 'XONLimDiv', IntToStr(fXONLimDiv));
        WriteString(RegSubKey, 'XOFFLimDiv', IntToStr(fXOFFLimDiv));
        WriteString(RegSubKey, 'FlowControl', IntToStr(fFlowControl));
        WriteBool  (RegSubKey, 'StripNullChars', fStripNullChars);
        WriteString(RegSubKey, 'EventChar', fEventChar);
        WriteString(RegSubKey, 'RTOCharDelayTime', IntToStr(fRTOCharDelayTime));
        WriteString(RegSubKey, 'RTOExtraDelayTime', IntToStr(fRTOExtraDelayTime));
        WriteString(RegSubKey, 'ClusterSize', IntToStr(fClusterSize));
        WriteString(RegSubKey, 'RxQueueSize', IntToStr(fRxQueueSize));
        WriteString(RegSubKey, 'TxQueueSize', IntToStr(fTxQueueSize));
        WriteString(RegSubKey, 'WTOCharDelayTime', IntToStr(fWTOCharDelayTime));
        WriteString(RegSubKey, 'WTOExtraDelayTime', IntToStr(fWTOExtraDelayTime));
        WriteBool  (RegSubKey, 'XTOAuto', fXTOAuto);
        WriteBool  (RegSubKey, 'RTSState', fRTSState);
        WriteBool  (RegSubKey, 'DTRState', fDTRState);
        WriteBool  (RegSubKey, 'BREAKState', fBREAKState);
        WriteString(RegSubKey, 'ErrorNoise', IntToStr(fErrorNoise));
        WriteBool  (RegSubKey, 'Active', FActive);
        ProcessError(0501,0,'Settings saved',enMsg);
      end;
    except
      ProcessError(0502,0,'Error saving Settings',enError);
    end;
  finally
    FIniFile.Free;
  end;
end;

// Read all Settings from the Registry
// e.g. ReadSettings('Software/DomIS','SerialNGAdvDemo')
// will read from HKEY_CURRENT_USER\Software\DomIS\SerialAdvDemo
procedure TSerialPortNG.ReadSettings(Regkey, RegSubKey : String);
var FIniFile : TRegIniFile;
    function CharFromStr(S : String):Char;
    begin
      if Length(S) > 0 then
        CharFromStr := S[1]
      else
        CharFromStr := #0;
    end;

begin
  FIniFile := TRegIniFile.Create(RegKey);
  try