unit Com;

interface

uses
  Windows, ExtCtrls;

type
  TReadComProc = procedure (Data: String) of object;
  //example:
  //procedure TMainForm.ReadCom(Data: String);

  TCom = class(TObject)
  private
    function GetConnected: Boolean;
  public
    OnReadCom: TReadComProc;
    constructor Create;
    destructor Destroy; override;

    function OpenCom(Port: Byte): Boolean;
    procedure SetBaud(Baud: LongWord);
    procedure CloseCom;
    function WriteComLine(Data: String): LongWord;
    property Connected: Boolean read GetConnected default False;
  private
    //COM port access variables
    hCom: hWnd;
    ComDCB: DCB;
    //Asynchronous read variables
    osReader, osWriter: OVERLAPPED;
    InBuf: ShortString;
    BytesRead: LongWord;
    InLin: String;
    InTime: TTimer;

    function StartRead: Boolean;
    procedure InTimeTimer(Sender: TObject);
  end;

implementation

uses
  Math, SysUtils;

constructor TCom.Create;
begin
  inherited Create;
  InTime := TTimer.Create(nil);
  InTime.Enabled := False;
  InTime.Interval := 25;
  InTime.OnTimer := InTimeTimer;
end;

destructor TCom.Destroy;
begin
  InTime.Free;

  //Release the memory used by the read event
  if osReader.hEvent <> 0 then CloseHandle(osReader.hEvent);
  //Release the COM port
  if hCom <> INVALID_HANDLE_VALUE then CloseHandle(hCom);

  inherited Destroy;
end;

function TCom.OpenCom(Port: Byte): Boolean;
var
  Tim: COMMTIMEOUTS;
  ComStr: String;

begin
  Result := False;
  if InTime.Enabled then Exit;

  ComStr := '\\.\COM' + IntToStr(Port);                                                  //asynchronous
  hCom := CreateFile(@ComStr[1], GENERIC_READ + GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);

  if hCom = INVALID_HANDLE_VALUE then begin //If failed to open COM port
    Exit;
  end;
  //Else we can use the port, so let's set up communications

  SetupComm(hCom, 1026, 255); //In buffer = 1026 bytes, out buffer = 255 bytes

  Tim.ReadIntervalTimeout := 5;
  Tim.ReadTotalTimeoutConstant := 0;    //No read total timeout, we want to get all the data that comes our way
  Tim.ReadTotalTimeoutMultiplier := 0;
  Tim.WriteTotalTimeoutConstant := 0;   //No write timeout.
  Tim.WriteTotalTimeoutMultiplier := 0;
  SetCommTimeouts(hCom, Tim);

  GetCommState(hCom, ComDCB); //Fill ComDCB with current data
  ComDCB.BaudRate := 9600;
  ComDCB.ByteSize := 7;
  ComDCB.Parity   := EVENPARITY;
  ComDCB.StopBits := ONESTOPBIT;
  SetCommState(hCom, ComDCB);

  Result := StartRead;
  if not Result then CloseCom;
end;

procedure TCom.SetBaud(Baud: LongWord);
begin
  if not InTime.Enabled then Exit;
  ComDCB.BaudRate := Baud;
  ComDCB.ByteSize := 7;
  ComDCB.Parity   := EVENPARITY;
  ComDCB.StopBits := ONESTOPBIT;
  SetCommState(hCom, ComDCB);
end;

procedure TCom.CloseCom;
begin
  if not InTime.Enabled then Exit;
  InTime.Enabled := False;

  //Release the COM port
  CloseHandle(hCom);

  hCom := INVALID_HANDLE_VALUE;
  //InTime.Enabled := False;
end;

function TCom.WriteComLine(Data: String): LongWord;
var
  Buf: String;
  ILen: LongWord;
  timeout:LongWord;
begin
  Result := 0;
  if not InTime.Enabled then Exit;
  Buf := Data + #13;

  ILen := Length(Buf);
//  SetLastError(ERROR_SUCCESS);
  WriteFile(hCom, Buf[1], ILen, Result, @osWriter);
//  repeat until (GetLastError <> ERROR_IO_PENDING);
end;

function TCom.StartRead: Boolean;
const
  FirstRead: Boolean = True;

begin
  InTime.Enabled := False;

  if FirstRead then begin //Handle creation of the asynchronous structures and read event
    osWriter.Internal := 0;
    osWriter.InternalHigh := 0;
    osWriter.Offset := 0;
    osWriter.OffsetHigh := 0;
    osWriter.hEvent := 0;

    osReader.Internal := 0;
    osReader.InternalHigh := 0;
    osReader.Offset := 0;
    osReader.OffsetHigh := 0;
    osReader.hEvent := CreateEvent(nil, True, False, nil);

    FirstRead := False;
  end;

  Result := False;
  repeat
    if ReadFile(hCom, InBuf[1], 255, BytesRead, @osReader) then begin //if read completed immediately
      InBuf[0] := Char(BytesRead); //Note the length of the incoming string
      InLin := InLin + InBuf;
    end
    else if GetLastError = ERROR_IO_PENDING then //elseif the problem was that we'll have to wait, good - setup reading
      Result := True
    else
      Exit
    ;
  until Result;
  InTime.Enabled := True;
end;

procedure TCom.InTimeTimer(Sender: TObject);
const
  Parsing: Boolean = False;
var
  I: LongWord;

begin
  if not GetOverlappedResult(hCom, osReader, BytesRead, False) then begin

    if Parsing then Exit;
    Parsing := True;
    try
      if Length(InLin) > 0 then begin
        I := Pos(#13, InLin);
        while I <> 0 do begin
          if Assigned(OnReadCom) then OnReadCom(Copy(InLin, 1, I-1));
          InLin := Copy(InLin, I+1, Length(InLin));
          I := Pos(#13, InLin);
        end;
      end;
    finally
      Parsing := False;
    end;
  end
  else begin
    InBuf[0] := Char(BytesRead); //Note the length of the incoming string
    InLin := InLin + InBuf;
    StartRead;
  end;
end;

function TCom.GetConnected: Boolean;
begin
  Result := InTime.Enabled;
end;

end.