serialng.pas

RS232 Source using delphi

// One part of the Clusterdefinition is here, please read carefully
// The "RTOCharDelayTime" is the Time that may delay between two received Chars
// This Time should be Computed depending from the Baudrate e.g. 9600 Baud -> 960 Chars per Second -> Delay 1ms
// You can use the CharDelayDefault Procedure to set RTOCharDelayTime and WTOCharDelayTime depending
// of the selected Baudrate!
    property RTOCharDelayTime : DWord read fRTOCharDelayTime write SetRTOCharDelayTime default dflt_RTOCharDelayTime;
// The "RTOExtraDelayTime" is the Time that may delay addionally once
// So if the (CharCount*RTOCharDelayTime)/1000 + RTOExtraDelayTime extends the measured Time, a Cluster will be build
    property RTOExtraDelayTime : Word read fRTOExtraDelayTime write SetRTOExtraDelayTime default dflt_RTOExtraDelayTime;
// Clustersize specify how long one Cluster could become max
    property ClusterSize : Word read fClusterSize write SetClusterSize default dflt_ClusterSize;
// RxQueueSize specify the amount of Chars that could be received without reading,
// this should be longer than the Cluster size to prevent overrun errors
    property RxQueueSize : Word read fRxQueueSize write SetRxQueueSize default dflt_RxQueueSize;
    property TxQueueSize : Word read fTxQueueSize write SetTxQueueSize default dflt_TxQueueSize;

    property WTOCharDelayTime : DWord read fWTOCharDelayTime write SetWTOCharDelayTime default dflt_WTOCharDelayTime;
    property WTOExtraDelayTime : Word read fWTOExtraDelayTime write SetWTOExtraDelayTime default dflt_WTOExtraDelayTime;
    property XTOAuto : Boolean read fXTOAuto write SetXTOAuto default dflt_XTOAuto;
    property RTSState : Boolean read fRTSState write SetSignalRTS default dflt_RTSState;
    property DTRState : Boolean read fDTRState write SetSignalDTR default dflt_DTRState;
    property BREAKState : Boolean read fBREAKState write SetSignalBREAK default dflt_BreakState;
    property CTSState : Boolean read fCTSState;
    property DSRState : Boolean read fDSRSTate;
    property RLSDState : Boolean read fRLSDState;
    property RingState : Boolean read fRingState;
    property ErrorNoise : Byte read fErrorNoise write SetErrorNoise default dflt_ErrorNoise;
    property ReadRequest : Boolean read fReadRequest write SetReadRequest default False;
    property SendInProgress : Boolean read fSendInProgress;
    property CommError : DWord read fCommError;
    property CommStateFlags : TComStateFlags read fCommStateFlags;
    property CommStateInQueue: DWord read fCommStateInQueue;
    property CommStateOutQueue : DWord read fCommStateOutQueue;
    property ModemState : DWord read fModemState;
    property CommEvent : DWord read fCommEvent;
    property WrittenBytes : DWord read fWrittenBytes;
    // Event Properties
    property OnCommEvent : TNotifyEvent read fOnCommEvent write fOnCommEvent;
    property OnCommStat : TNotifyEvent read fOnCommStat write fOnCommStat;
    property OnTxQueueEmptyEvent : TNotifyEvent read fOnTxQueueEmptyEvent write fOnTxQueueEmptyEvent;
    property OnWriteDone : TNotifyEvent read fOnWriteDone write fOnWriteDone;
    property OnBreakEvent : TNotifyEvent read fOnBreakEvent write fOnBreakEvent;
    property OnCTSEvent : TNotifyEvent read fOnCTSEvent write fOnCTSEvent;
    property OnDSREvent : TNotifyEvent read fOnDSREvent write fOnDSREvent;
    property OnLineErrorEvent : TNotifyEvent read fOnLineErrorEvent write fOnLineErrorEvent;
    property OnRingEvent : TNotifyEvent read fOnRingEvent write fOnRingEvent;
    property OnRLSDEvent : TNotifyEvent read fOnRLSDEvent write fOnRLSDEvent;
    property OnRxClusterEvent : TNotifyEvent read fOnRxClusterEvent write fOnRxClusterEvent;
    property OnRxCharEvent : TNotifyEvent read fOnRxCharEvent write fOnRxCharEvent;
    property OnRxEventCharEvent : TNotifyEvent read fOnRxEventCharEvent write fOnRxEventCharEvent;
    property OnProcessError : TNotifyErrorEvent read fOnProcessError write fOnProcessError;
  end;

// The TWorkThread class deals with several CommEvents and controll the receiving
// of Clusters and check the Sendprocess
// Under normal cirumstances You don't have to deal with
  TWorkThread = class(TThread)
  private
    Owner : TSerialPortNG;
    Place, Code : DWord;
    Msg : String;
    Noise : Byte;
    Cluster : TSerialCluster;
    procedure SetProcessError(APlace, ACode : DWord; AMsg : String; ANoise : Byte);
    procedure ProcessError;
    procedure RxClusterEvent;
    procedure CommEvent;
    procedure CommStatEvent;
    procedure BreakEvent;
    procedure CTSEvent;
    procedure DSREvent;
    procedure LineErrorEvent;
    procedure RingEvent;
    procedure RLSDEvent;
    procedure RxCharEvent;
    procedure RxEventCharEvent;
    procedure TxQueueEmptyEvent;
    procedure WriteDone;

  protected
  public
    constructor Create(AOwner : TSerialPortNG);
    procedure Execute; override;
  end;

procedure Register;
procedure GetCommNames(CommNames : TStrings);

implementation
uses Registry;

var VersionInfo : TOSVersionInfo;

procedure Register;
begin
  RegisterComponents('Samples', [TSerialPortNG]);
end;

// Help function for OS Detection
function CheckOS(var VersionInfo : TOSVersionInfo) : Integer;
begin
{
    dwOSVersionInfoSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformId: DWORD;
    szCSDVersion: array[0..127] of AnsiChar; // Maintenance string for PSS usage
}
  VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
  if GetVersionEx(VersionInfo) then
    CheckOS := VersionInfo.dwPlatformId
  else
    CheckOS := -1;
end;

// Help function to collect CommPortNames
procedure GetCommNames(CommNames : TStrings);
// From:[e-mail] (AlanGLLoyd)
// Organization:AOL, http://www.aol.co.uk
// Newsgroups:alt.comp.lang.borland-delphi

{searches the *PNP0501 and SerialComm entries in the registry fo commport
names}
var
  Reg : TRegistry;
  SerPtSL : TStringList;
  i : integer;
  CommStr : string;
const
  CommPNPKey : string = '\Enum\BIOS\*PNP0501';
  HardwareKey : string = '\hardware\devicemap\serialcomm';
var
  LogStr : String;
  S : String;
begin
  {stringlist to hold key or value names during search}
  SerPtSL := TStringList.Create;
  Reg := TRegistry.Create;
  with Reg do begin
    RootKey := HKEY_LOCAL_MACHINE;
    LogStr := LogStr + '  HKEY_LOCAL_MACHINE' + #13;
    {check PNP entries}
    if OpenKey(CommPNPKey, false) then begin
      LogStr := Format('%s  %s opened%s', [LogStr, CommPNPKey, #13]);
      {get all serial port keys - one key for each interupt used}
      GetKeyNames(SerPtSL);
      {get the Comm names for all the keys - into CommSL}
      for i := 0 to SerPtSL.Count - 1 do begin
        OpenKey(CommPNPKey + '\' + SerPtSL.Strings[i], false);
        if GetDataType('PortName') = rdString then begin
        // Prevent duplicate Entries (ED 18.9.2001
          S := ReadString('PortName');
          if CommNames.IndexOf(S) < 0 then begin
            CommNames.Add(S);
            LogStr := Format('%s    %s%s', [LogStr, CommNames.Strings[i], #13]);
          end;
        end;
      end; {for i := 0 to SerPtSL.Count - 1}
      end {if OpenKey(CommPNP, false) else}
    else
      LogStr := LogStr + '  Unable to open ' + CommPNPKey + #13;
    SerPtSL.Clear; // to use for hardware value names
    {check the hardware entries}
    if OpenKey(HardwareKey, false) then begin
      LogStr := Format('%s  %s opened%s', [LogStr, HardwareKey, #13]);
      {get the value names for the commports - NT is "Serialn" W95 is "COMn"}
      GetValueNames(SerPtSL);
      {now get the data value for each commport}
      for i := 0 to SerPtSL.Count - 1 do
        if GetDataType(SerPtSL.Strings[i]) = rdString then begin
          CommStr := ReadString(SerPtSL.Strings[i]);
          LogStr := LogStr + '    ' + CommStr;
          {if its not in CommNames already ...}
          if CommNames.IndexOf(CommStr) < 0 then begin
            {... add it}
            CommNames.Add(CommStr);
            LogStr := LogStr + ' added' + #13;
            end
          else
            LogStr := LogStr + ' already in list' + #13;
          end;
        end {if GetDataType(SerPtSL.Strings[i]) = rdString}
      {end; for i := 0 to SerPtSL.Count - 1}
    else
      LogStr := Format('%s  Unable to open %s', [LogStr, HardwareKey, #13]);
    {end; if OpenKey(HardwareKey, false) else}
    Free; // TFegistry
  end;
  SerPtSL.Free;
end;

//
// TSerialCluster Component
//

constructor TSerialCluster.Create(Data : Pointer; Size : Integer; CCError : DWord);
begin
  inherited Create;
  ClusterData := Data; // Take the Pointer
  ClusterSize := Size; // Size of Data
  ClusterCCError := CCError;
end;

function TSerialCluster.GetCCError : DWord;
begin
  GetCCError := ClusterCCError;
end;

function TSerialCluster.GetSize : Integer;
begin
  GetSize := ClusterSize;
end;

procedure TSerialCluster.GetData(Dest : Pointer);
begin
  if Dest <> Nil then
    Move(ClusterData^, Dest^, ClusterSize);
end;

function TSerialCluster.GetDataAsString : String;
var S : String;
begin
  SetLength(S,ClusterSize);
  Move(ClusterData^, S[1], ClusterSize);
  GetDataAsString := S;
end;

function TSerialCluster.GetDataAsPChar(Dest : PChar) : PChar;
type TMaxSize = array[0..MaxLongInt-1] of Char;
     PMaxSize = ^TMaxSize;
begin
  if Dest <> Nil then
    begin
      Move(ClusterData^, Dest^, ClusterSize);
      PMaxSize(Dest)^[ClusterSize] := #0;
    end;
  GetDataAsPChar := Dest;
end;

destructor TSerialCluster.Destroy;
begin
  Dispose(ClusterData);
  inherited Destroy;
end;


//
// TSerialPortNG Component definition
//

//
// Serveral "Set..." procedure for the Property mapping

procedure TSerialPortNG.SetCommPort(value : ShortString);
begin
  if value <> fCommPort then
    begin
      fCommPort := value;
      PortWork(fActive);
    end;
end;

procedure TSerialPortNG.SetBaudRate(value : DWord);
begin
  if value <> fBaudRate then
    begin
      fBaudRate := value;
      if fXTOAuto then
        XTODefault; // Adjust the CharDelay Timeouts
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetParityType(value : Byte);
begin
  if value <> fParityType then
    begin
      fParityType := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetParityErrorChar(value : Char);
begin
  if value <> fParityErrorChar then
    begin
      fParityErrorChar := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetParityErrorReplacement(value : Boolean);
begin
  if value <> fParityErrorReplacement then
    begin
      fParityErrorReplacement := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetStopBits(value : Byte);
begin
  if value <> fStopBits then
    begin
      fStopBits := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetDataBits(value : Byte);
begin
  if value <> fDataBits then
    begin
      fDataBits := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetXONChar(value : Char);
begin
  if value <> fXONChar then
    begin
      fXONChar := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetXOFFChar(value : Char);
begin
  if value <> fXOFFChar then
    begin
      fXOFFChar := value;
      if fActive then
        SetupDCB;
    end;
end;

procedure TSerialPortNG.SetXONLimDiv(value : Byte);
begin
  if value <> fXONLimDiv then
    begin
      if value > 100 then
        begin
          ProcessError(0100,value,'Warning XOnLimDef set to 100',enWarning);