//Использование в коммерческих целях запрещено.
//Наказание - неминуемый кряк и распространение по всему инет.
//Business application is forbidden.
//Punishment - unavoidable crack and propagation on everything inet.
unit ComPort;

interface
uses Windows, SysUtils, Classes, D2XXUnit;

var
  iComNum: integer = 2; // номер COM порта
  iOldComOpen: integer = 0;
  iComBaud: integer = 115200; // Скорость COM порта
  iOldComBaud: integer = 0;
  hCom: THandle = INVALID_HANDLE_VALUE;
  ComTimeouts: TCommTimeouts;
  txLen, rxLen: Dword;
  FlgOvrlp: boolean = True;
  COMwr: OVERLAPPED;
  COMrd: OVERLAPPED;
  COMst: COMSTAT;
  DCB: TDCB;
  ComListStr: TStrings;
  port: integer;

{ Флаги в DCB :
0      DWORD fBinary: 1;          // binary mode, no EOF check
1      DWORD fParity: 1;          // enable parity checking
2      DWORD fOutxCtsFlow:1;      // CTS output flow control
3      DWORD fOutxDsrFlow:1;      // DSR output flow control
4..5   DWORD fDtrControl:2;       // DTR flow control type
6      DWORD fDsrSensitivity:1;   // DSR sensitivity
7      DWORD fTXContinueOnXoff:1; // XOFF continues Tx
8      DWORD fOutX: 1;        // XON/XOFF out flow control
9      DWORD fInX: 1;         // XON/XOFF in flow control
10     DWORD fErrorChar: 1;   // enable error replacement
11     DWORD fNull: 1;        // enable null stripping
12..13 DWORD fRtsControl:2;   // RTS flow control
14     DWORD fAbortOnError:1; // abort reads/writes on error
15..31 DWORD fDummy2:17;      // reserved}

function OpenCom(Mode: boolean): boolean;
procedure CloseCom;
function GetComDCB: boolean;
function SetComDCB: boolean;
function GetComTimeouts: boolean;
function SetComTimeouts: boolean;
function SetComRxTimeouts(NewIntervalTimeout, NewTimeoutMultiplier, NewTimeoutConstant: dword): boolean;
function ReadCom(Buf: Pointer; BufLen: Dword): boolean;
function WriteCom(Buf: Pointer; BufLen: Dword): boolean;
function EscapeComFunction(dwFunc: Dword): boolean;
function GetComModemStatus(lpModemStat: Pointer): boolean;
function GetComStat: boolean;
function PurgeCom(mode: Dword): boolean;
function WriteComStr(S: string): boolean;
function ChangeComSpeed(Baud: integer): boolean;
procedure ComList();
function CheckCom(): boolean;
procedure UFSList();

implementation

procedure UFSList();
var
  i: integer;
  s: string;
begin
  GetFTDeviceCount;
  if FT_Device_Count < 1 then exit;
  for i := 0 to FT_Device_Count - 1 do begin
    if FT_Open(i, @FT_Handle) = FT_OK then begin
      FT_Close(FT_Handle);
      GetFTDeviceDescription(i);
      s := FT_Device_String;
      if Pos('UFS', s) <> 0 then begin
        GetFTDeviceSerialNo(i);
        s := s + ' S/N ' + FT_Device_String;
        ComListStr.Add(s);
      end;
    end;
  end;
end;

procedure ComList();
var
  i: integer;
begin
  ComListStr.Clear;
  for i := 1 to 255 do begin
    iComNum := i;
    if CheckCom = true then begin
      ComListStr.Add('COM' + IntToStr(i));
    end;
  end;
end;

function CheckCom(): boolean;
var
  hPort: THandle; //дескриптор порта
begin {InitPort}
  Result := false;
  hPort := CreateFile(PChar('\\?\COM' + IntToStr(iComNum)),
    GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE,
    nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  if hPort = INVALID_HANDLE_VALUE then Exit;
  CloseHandle(hPort);
  Result := true;
end;

function OpenCom(Mode: boolean): boolean;
var
  dw: dword;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then CloseCom;
  if FlgOvrlp then dw := FILE_FLAG_OVERLAPPED
  else dw := FILE_ATTRIBUTE_NORMAL;
  hCom := CreateFile(PChar('\\?\COM' + IntToStr(iComNum)), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, dw, 0);
  if hCom <> INVALID_HANDLE_VALUE then begin
    SetupComm(hCom, $20000, $20000); //8192, 8192); // Rd , Wr
    if GetComDCB then begin
      if Mode then DCB.Flags := (DCB.Flags and $FFFF8000) or $0001
      else DCB.Flags := (DCB.Flags and $FFFF8000) or $0011; //$1011;
      DCB.ByteSize := 8;
//    DCB.Parity := 0;
      DCB.StopBits := 0;
      DCB.BaudRate := iComBaud;
      if SetComDCB then begin
        ComTimeouts.ReadIntervalTimeout := 20; //0
        ComTimeouts.ReadTotalTimeoutMultiplier := 1; //0
        ComTimeouts.ReadTotalTimeoutConstant := 200; //200
        ComTimeouts.WriteTotalTimeoutMultiplier := 0; //MAXDWORD;
        ComTimeouts.WriteTotalTimeoutConstant := 0; //MAXDWORD;
        if SetComTimeouts then begin
          iOldComOpen := iComNum;
          iOldComBaud := iComBaud;
          if Mode then begin
            sleep(75);
            EscapeComFunction(SETRTS);
            sleep(25);
            EscapeComFunction(SETDTR);
          end
          else begin
            sleep(75);
            EscapeComFunction(SETRTS);
          end;
//      sleep(300);
//      PurgeCom(PURGE_TXCLEAR or PURGE_RXCLEAR);
          result := TRUE;
        end;
      end;
    end;
  end;
end;

procedure CloseCom;
var
  x: THandle;
begin
  if hCom <> INVALID_HANDLE_VALUE then begin
    x := hCom;
    hCom := INVALID_HANDLE_VALUE;
    CloseHandle(x);
  end;
// hCom:=INVALID_HANDLE_VALUE;
  iOldComOpen := 0;
end;

function GetComDCB: boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    result := GetCommState(hCom, DCB);
end;

function SetComDCB: boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    result := SetCommState(hCom, DCB);
end;

function ChangeComSpeed(Baud: integer): boolean;
var
  save_baud: integer;
begin
  result := FALSE;
  save_baud := dcb.BaudRate;
  if hCom <> INVALID_HANDLE_VALUE then begin
//  dcb.BaudRate:=Baud;
    if GetComDCB then begin
      if dcb.BaudRate <> Dword(Baud) then begin
        dcb.BaudRate := Baud;
        result := SetCommState(hCom, DCB);
        EscapeComFunction(SETRTS);
        EscapeComFunction(SETDTR);
        if not result then begin
          dcb.BaudRate := save_baud;
          SetCommState(hCom, DCB);
          EscapeComFunction(SETRTS);
          EscapeComFunction(SETDTR);
        end;
      end;
    end;
  end;
end;

function GetComTimeouts: boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    result := GetCommTimeouts(hCom, ComTimeouts);
end;

function SetComTimeouts: boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    if SetCommTimeouts(hCom, ComTimeouts) then result := TRUE;
end;

function SetComRxTimeouts(NewIntervalTimeout, NewTimeoutMultiplier, NewTimeoutConstant: dword): boolean;
begin
  result := FALSE;
  if (ComTimeouts.ReadIntervalTimeout <> NewIntervalTimeout)
    or (ComTimeouts.ReadTotalTimeoutMultiplier <> NewTimeoutMultiplier)
    or (ComTimeouts.ReadTotalTimeoutConstant <> NewTimeoutConstant)
    then begin
    ComTimeouts.ReadIntervalTimeout := NewIntervalTimeout;
    ComTimeouts.ReadTotalTimeoutMultiplier := NewTimeoutMultiplier;
    ComTimeouts.ReadTotalTimeoutConstant := NewTimeoutConstant;
    if hCom <> INVALID_HANDLE_VALUE then
      if SetCommTimeouts(hCom, ComTimeouts) then result := TRUE;
  end
  else result := TRUE;
end;

function GetComStat: boolean;
var
  dErr: DWORD;
begin
  result := FALSE;
  dErr := 0;
// rxLen := 0;
  if hCom <> INVALID_HANDLE_VALUE then begin
    if ClearCommError(hCom, dErr, @COMst) then begin
     // size Rx buff := COMst.cbInQue;
      Result := True;
    end;
  end;
end;

function ReadCom(Buf: Pointer; BufLen: Dword): boolean;
var
  dErr: Dword;
begin
  result := False;
  if (hCom <> INVALID_HANDLE_VALUE) and (Buf <> nil) and (BufLen <> 0) then begin
    rxlen := 0;
    if FlgOvrlp then begin
      COMrd.hEvent := CreateEvent(nil, TRUE, FALSE, nil);
      if not ReadFile(hCom, Buf^, BufLen, rxLen, @COMrd) then begin
        if not GetOverlappedResult(hCom, COMrd, rxLen, True) then begin
        end;
      end;
//   ResetEvent(COMrd.hEvent);
      CloseHandle(COMrd.hEvent);
    end
    else begin
      if not ReadFile(hCom, Buf^, BufLen, rxLen, nil) then begin
//     ClearCommError(hCom,dErr,Nil);
//     exit;
      end;
    end;
    if rxLen = BufLen then result := True
    else ClearCommError(hCom, dErr, nil);
  end;
end;

function WriteCom(Buf: Pointer; BufLen: Dword): boolean;
var
  dErr: Dword;
begin
  result := FALSE;
  if (hCom <> INVALID_HANDLE_VALUE) and (Buf <> nil) and (BufLen <> 0) then begin
    txLen := 0;
    if FlgOvrlp then begin
      COMwr.hEvent := CreateEvent(nil, TRUE, FALSE, nil);
      if not WriteFile(hCom, Buf^, BufLen, txLen, @COMwr) then begin
        if not GetOverlappedResult(hCom, COMwr, txLen, True) then begin
        end;
//     ClearCommError(hCom,dErr,Nil);
      end;
//   ResetEvent(COMwr.hEvent);
      CloseHandle(COMwr.hEvent);
    end
    else begin
      if not WriteFile(hCom, Buf^, BufLen, txLen, nil) then begin
//     ClearCommError(hCom,dErr,Nil);
//     exit;
      end;
    end;
    if txLen = BufLen then result := TRUE
    else ClearCommError(hCom, dErr, nil);
  end;
end;

function WriteComStr(S: string): boolean;
begin
  Result := WriteCom(@S[1], Length(S));
end;

function PurgeCom(mode: Dword): boolean; //function
begin
  result := PurgeComm(hCom, mode); // сбросить буфера
end;

function EscapeComFunction(dwFunc: Dword): boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    result := EscapeCommFunction(hCom, dwFunc);
end;


function GetComModemStatus(lpModemStat: Pointer): boolean;
begin
  result := FALSE;
  if hCom <> INVALID_HANDLE_VALUE then
    result := GetCommModemStatus(hCom, LpDword(lpModemStat)^);
end;

end.