unit Seriell;

interface

uses SysUtils, WinProcs, Classes, ExtCtrls;

type
  eParity = ( paNone, PaOdd, paEven, paMark, paSpace);
  eDataBits = (d7bit, d8bit);
  eStopBits = (st1bit, st2bit);
  sPorts = 1..9;
  eFlowControl = (fcNone, fcRTS_CTS, fcDTR_DSR, fcXON_XOF);
  eOpModes = (rxNormal, rxMessage);
  eModemInSignal = (msCTS, msDSR, msRLSD);
  eModemOutSignal = (msRTS, msDTR);
  TOnRxData = procedure (Sender : TObject; sDaten, sDSR: String) of object;
  TSeriell = class(TComponent)
  private
	Used : Boolean;
	FPort : sPorts;
	FBaudrate : Integer;
	FParity : eParity;
	FDataBits : eDataBits;
	FStopBits : eStopBits;
	FActive : Boolean;
	FFlowMode : eFlowControl;
	FCheckParity : Boolean;
	FRxEventMode : eOpModes;
	FErrorCode : Integer;
	FCID : THANDLE;
	FDCB : TDCB;
	FCTO : TCOMMTIMEOUTS;
	FThreadActive : Boolean;
	DSRSignalState : Boolean;
	WrittenBytes : DWORD;
	OverlapBlock : TOverlapped;
	FOnRxData : TOnRxData;
	FEventThread : TThread;
	FEventThreadOut : TThread;
	procedure SetPort (nPort : sPorts);
	procedure SetBaud (Baud : Integer);
	procedure SetParity (Parity : eParity);
	procedure SetData (Data : eDatabits);
	procedure SetStop (Stop : eStopbits);
	procedure SetActive (bActive : Boolean);
	procedure SetFlowMode (mode : eFlowControl);
	procedure SetParityCheck (check : Boolean);
	procedure SetupDCB;
	procedure ReOpenPort(toOpen : Boolean);
	procedure EnableEvents;
	procedure ProcessError;
  public
	PointerE: LongInt;
	PointerA: LongInt;
	ArrayRx : String;
	ArrayDSR: String;
	sDaten, sDSR: String;
	constructor Create (aOwner : TComponent); override;
	destructor Destroy; override;
	function ReadChar (var c : Char) : Integer;
	function ReadString (var s : String) : Integer;
	procedure SetSignal (signal : eModemOutSignal; state : Boolean);
	property Active : Boolean read FActive write SetActive default False;
  published
	property Port : sPorts read FPort write SetPort default 1;
	property Baudrate : Integer read FBaudrate write SetBaud default 9600;
	property Parity : eParity read FParity write SetParity default paNone;
	property DataBits : eDataBits read FDataBits write SetData default d8bit;
	property StopBits : eStopBits read FStopBits write SetStop default st1bit;
	property FlowMode : eFlowControl read FFlowMode write SetFlowMode default fcDTR_DSR;
	property CheckParity : Boolean read FCheckParity write SetParityCheck default True;
	property ErrorCode : Integer read FErrorCode;
	property OnRxData: TOnRxData read FOnRxData write FOnRxData;
  end;

  TEventThread = class(TThread)
  private
	FPI : TSeriell;
  protected
	procedure Execute; override;
  public
	constructor Create(parentTSeriell : TSeriell);
  end;

  TEventThreadOut = class(TThread)
  private
	FPI : TSeriell;
  protected
	procedure Execute; override;
  public
	constructor Create(parentTSeriell : TSeriell);
  end;

const
	aBaudrates : Array [1..11] of Integer = (300, 600, 1200, 2400, 4800, 9600, 14400, 19200, 38400, 57600, 115200);
	aDatabits : Array[edataBits] of Byte = (7, 8);
	aParity : Array[eParity] of Byte = (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
	aStopbits : Array[eStopBits] of Byte = (ONESTOPBIT, TWOSTOPBITS);

implementation

constructor TSeriell.Create (aOwner : TComponent);
begin
	inherited Create (aOwner);
	Used := False;
	FPort := 1;
	FBaudrate := 9600;
	FParity := paNone;
	FDataBits := d8bit;
	FStopBits := st1bit;
	FActive := False;
	FFlowMode := fcDTR_DSR;
	FCheckParity := True;
	FRxEventMode := rxNormal;
	DSRSignalState := False;
	OverlapBlock.Offset := 0;
	OverlapBlock.OffsetHigh := 0;
	OverlapBlock.Internal := 0;
	OverlapBlock.InternalHigh := 0;
	OverlapBlock.hEvent :=  CreateEvent(nil, FALSE, TRUE, pChar('Event1'));
	FEventThread := TEventThread.Create(self);
	FEventThreadOut := TEventThreadOut.Create(self);
	FThreadActive := False;
	PointerE := 1;
	PointerA := 1;
	ArrayRx  := StringOfChar(#0,4000);
	ArrayDSR := StringOfChar(#0,4000);
end;

destructor TSeriell.Destroy;
begin
	ReopenPort (False);
	FEventThread.Terminate;
	FEventThreadOut.Terminate;
	inherited Destroy;
end;

procedure TSeriell.SetPort (nPort : sPorts);
begin
	if FPort <> nPort then
	begin
		FPort := nPort;
		ReOpenPort(FActive);
	end
end;

Procedure TSeriell.SetBaud (Baud : Integer);
var	i : Integer;
	baud_ok : Boolean;
begin
	baud_ok := False;
	for i:=Low(aBaudrates) to High(aBaudrates) do
		if Baud=aBaudrates[i] then baud_ok := True;
	if baud_ok then
	begin
		if FBaudrate<>Baud then
		begin
			FBaudrate := Baud;
			ReopenPort(FActive);
		end;
	end;
end;

procedure TSeriell.SetParity (Parity : eParity);
begin
	if FParity <> Parity then
	begin
		FParity := Parity;
		ReopenPort(FActive);
	end;
end;

procedure TSeriell.SetData (Data : eDatabits);
begin
	if FDataBits <> Data then
	begin
		FDataBits := Data;
		ReopenPort(FActive);
	end;
end;

procedure TSeriell.SetStop (Stop : eStopbits);
begin
	if FStopBits <> Stop then
	begin
		FStopBits := Stop;
		ReopenPort(FActive);
	end;
end;

procedure TSeriell.SetActive (bActive : Boolean);
begin
	ReOpenPort(bActive);
end;

procedure TSeriell.SetFlowMode (mode : eFlowControl);
begin
	if FFlowMode <> mode then
	begin
		FFlowMode := mode;
		ReopenPort(FActive);
	end;
end;

procedure TSeriell.SetParityCheck (check : Boolean);
begin
	if FCheckParity<>check then
	begin
		FCheckParity := check;
		ReopenPort(FActive);
	end;
end;

procedure TSeriell.SetupDCB;
begin
	FDCB.DCBLength := SizeOf (TDCB);
	FDCB.BaudRate := FBaudRate;
	FDCB.Flags := $0001;
	if FCheckParity then FDCB.Flags := FDCB.Flags or $0002;
	case FFlowMode of
	fcRTS_CTS: FDCB.Flags := FDCB.Flags or (RTS_CONTROL_HANDSHAKE shl 12) or $0004;
	fcDTR_DSR: FDCB.Flags := FDCB.Flags or (DTR_CONTROL_HANDSHAKE shl 4) or $0008;
	fcXON_XOF: FDCB.Flags := FDCB.Flags or $0300;
	end;
	FDCB.ByteSize := aDatabits[FDataBits];
	FDCB.Parity := aParity[FParity];
	FDCB.StopBits := aStopbits[FStopBits];
	FDCB.XonChar := Chr(17);
	FDCB.XoffChar := Chr(19);
	FDCB.ErrorChar := '?';
	if FActive then
	begin
		if not SetCommState(FCID, FDCB) then ProcessError;
		FCTO.ReadIntervalTimeout := MAXDWORD;
		FCTO.ReadTotalTimeoutMultiplier := 0;
		FCTO.ReadTotalTimeoutConstant := 0;
		if FFlowMode <> fcNone then
		begin
			FCTO.WriteTotalTimeoutMultiplier := 0;
			FCTO.WriteTotalTimeoutConstant := 10000;
		end;
		if not SetCommTimeouts (FCID, FCTO) then ProcessError;
	end;
end;

procedure TSeriell.ReOpenPort(toOpen : Boolean);
var	pname : Array[0..10] of char;
	ret, InQueue, OutQueue : DWord;
	count : Integer;
	FCommTimeouts : TCommTimeouts;
	PConfig : array [0 .. 11] of char;
	Res : Boolean;
	CommProp 	: TCommProp;
begin
	if FActive then
	begin
		if not PurgeComm (FCID, PURGE_TXABORT or PURGE_RXABORT) then ProcessError;
		SetSignal (msDTR, False);
		SetSignal (msRTS, False);
		FActive := False;
		if not SetCommMask (FCID, 0) then ProcessError;
		count := 40;
		while FThreadActive and (count > 0) do
		begin
			Sleep(25);
			count := count - 1;
		end;
		if not CloseHandle(FCID) then ProcessError;
	end;
	if (toOpen) then
	begin
		StrPcopy(pname, Format('COM%d', [FPort]));
		ret := CreateFile (pname, (GENERIC_READ or GENERIC_WRITE), 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
		if ret <> INVALID_HANDLE_VALUE then
		begin
			FCID := ret;
			FillChar (FDCB, Sizeof (TDCB), #0);
			FDCB.DCBLength := Sizeof (TDCB);
			BuildCommDCB (StrPCopy (PConfig, '9600,N,8,1'), FDCB);
			InQueue := 32768;
			OutQueue := 1024;
			Res := GetCommProperties (FCID, CommProp);
			if Res then
			begin
				if CommProp.dwMaxTxQueue <> 0 then
					if InQueue > CommProp.dwMaxTxQueue then InQueue := CommProp.dwMaxTxQueue;
				if CommProp.dwMaxRxQueue <> 0 then
					if OutQueue > CommProp.dwMaxRxQueue then OutQueue := CommProp.dwMaxRxQueue;
			end;
			SetCommState (FCID, FDCB);
			SetCommTimeouts (FCID, FCommTimeouts);
			if not SetupComm (FCID, InQueue, OutQueue) then ProcessError;
			FActive := True;
			SetupDCB;
			SetSignal(msDTR, TRUE);
			setSignal(msRTS, TRUE);
			EnableEvents;
		end
		else ProcessError;
	end;
end;

procedure TSeriell.EnableEvents;
begin
	if not SetCommMask (FCID, EV_RXCHAR or EV_TXEMPTY or EV_CTS or EV_DSR or EV_BREAK or EV_RLSD or EV_RING) then ProcessError;
	FEventThread.Resume;
	FEventThreadOut.Resume;
end;

procedure TSeriell.ProcessError;
begin
	FErrorCode := GetLastError();
end;

function TSeriell.ReadChar (var c: Char) : Integer;
var	buf : Array[0..1] of Char;
	Res : integer;
begin
	ReadChar := 0;
	Used := True;
	if not ReadFile (FCID, buf, 1, WrittenBytes, @OverlapBlock) then
	begin
		Res := WaitForSingleObject(OverlapBlock.hEvent,1);
		case Res of
		WAIT_OBJECT_0 :
			begin
				ResetEvent(OverlapBlock.hEvent);
				ReadChar := WrittenBytes;
			end;
		WAIT_TIMEOUT :
			begin
				ResetEvent(OverlapBlock.hEvent);
				WrittenBytes := 0;
				ReadChar := 0;
			end;
		else
			begin
				ProcessError;
				exit;
			end;
		end;
	end
	else
	begin
		ResetEvent(OverlapBlock.hEvent);
		ReadChar := WrittenBytes;
	end;
	OverlapBlock.Offset := 0;
	OverlapBlock.OffsetHigh := 0;
	if (WrittenBytes=1) then c := buf[0];
end;

function TSeriell.ReadString (var s : String) : Integer;
var	TestChar : char;
	i : integer;
begin
	s := '';
	for i := 0 to 4096 do
		if self.ReadChar(TestChar) > 0 then s := s + TestChar else System.Break;
	Result := Length(s);
end;

procedure TSeriell.SetSignal (signal : eModemOutSignal; state : Boolean);
var	func : DWORD;
begin
	func := 0;
	if signal=msRTS then
		if state then func := SETRTS
				 else func := CLRRTS
	else if signal=msDTR then
		if state then func := SETDTR
				 else func := CLRDTR;
	EscapeCommFunction (FCID, func);
end;

procedure TEventThread.Execute;
var	event, cstate, iget : DWORD;
	c: Char;
	d: TComponent;
begin
	d := TComponent(FPI.GetOwner).FindComponent('panMmVisual');
	while not Terminated do
	begin
		if FPI.Active then
		begin
			FPI.FThreadActive := True;
			WaitCommEvent(FPI.FCID, event, nil);
			If GetCommModemStatus(FPI.FCID, cstate) Then
				FPI.DSRSignalState := (cstate and MS_DSR_ON) <> 0;
			Repeat
				iget := FPI.ReadChar(c);
				If iget > 0 Then
				Begin
					FPI.ArrayRx[FPI.PointerE] := c;
					FPI.ArrayDSR[FPI.PointerE] := Chr(Ord(FPI.DSRSignalState));
					Inc(FPI.PointerE);
					If FPI.PointerE > 4000 Then FPI.PointerE := 1;
				End;
			Until iget < 1;
			If d = Nil Then Terminate else If Not TPanel(d).Visible Then Terminate;
		end
		else
		begin
			FPI.FThreadActive := False;
			Sleep(20);
		end;
	end;
end;

constructor TEventThread.Create(parentTSeriell : TSeriell);
begin
	inherited Create(True);
	Priority := tpTimeCritical;
	FreeOnTerminate := True;
	FPI := parentTSeriell;
end;

procedure TEventThreadOut.Execute;
begin
	while not Terminated do
	begin
		If FPI.PointerE <> FPI.PointerA Then
		Begin
			If TComponent(FPI.GetOwner).FindComponent('imgBinTerm') = Nil Then Terminate
			else If Not TImage(TComponent(FPI.GetOwner).FindComponent('imgBinTerm')).Visible Then Terminate;
			If FPI.PointerE > FPI.PointerA Then
			Begin
				FPI.sDaten := Copy(FPI.ArrayRx, FPI.PointerA, FPI.PointerE - FPI.PointerA);
				FPI.sDSR := Copy(FPI.ArrayDSR, FPI.PointerA, FPI.PointerE - FPI.PointerA);
			End Else Begin
				FPI.sDaten := Copy(FPI.ArrayRx, FPI.PointerA, 4001 - FPI.PointerA) + Copy(FPI.ArrayRx, 1, FPI.PointerE - 1);
				FPI.sDSR := Copy(FPI.ArrayDSR, FPI.PointerA, 4001 - FPI.PointerA) + Copy(FPI.ArrayDSR, 1, FPI.PointerE - 1);
			End;
			FPI.PointerA := FPI.PointerE;
			FPI.FOnRxData(FPI, FPI.sDaten, FPI.sDSR);
		End;
		Sleep(5);
	end;
end;

constructor TEventThreadOut.Create(parentTSeriell : TSeriell);
begin
	inherited Create(True);
	FreeOnTerminate := True;
	FPI := parentTSeriell;
end;

end.