unit ComPortOnline;

interface


uses
  Windows, SysUtils, Classes, Forms;

Type
 TByteSize = (
  bs5, bs6, bs7, bs8
 );
 TParity = (
  ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE
 );

 TStopbits = (
  sb1BITS, sb1HALFBITS, sb2BITS
 );

 TComPortOnline = class(TComponent)
  Protected
    FBaseAddress : Word;      {базовый адрес порта}
    FHandle      : THandle;   {дескриптор порта}
    FByteSize    : TByteSize; {число бит в байте}
    FStopbits    : TStopbits; {число стоп-бит}
    Procedure DoOpenPort; {открытие порта}
    Procedure DoClosePort; {закрытие порта}
  Private
    FComNumber: Integer;
    function  GetConnected: Boolean;
    procedure SetComNumber(const Value: Integer);
    procedure SetBaudRate(const Value: Cardinal);
    function  GetBaudRate : Cardinal;
    function  GetLineControl(const Index: Integer): Byte;
    procedure SetLineControl(const Index: Integer; const Value: Byte);
    function GetByteSize: TByteSize;
    function GetParity: TParity;
    function GetStopbits: TStopbits;
    procedure SetByteSize(const Value: TByteSize);
    procedure SetParity(const Value: TParity);
    procedure SetStopbits(const Value: TStopbits);
    function GetDTRRTS(const Index: Integer): Boolean;
    procedure SetDTRRTS(const Index: Integer; const Value: Boolean);
    function GetModemState(const Index: Integer): Boolean;
    procedure SetModemState(const Index: Integer; const Value: Boolean);
  Public
    Constructor Create(AOwner : TComponent); override;
    Destructor  Destroy; override;
  Public
    {Открывает/закрывает порт}
    Procedure Open;
    Procedure Close;


Function GetTest : Cardinal;
  Public
    Property Connected : Boolean read GetConnected;
    {Номер порта. При изменении порт переоткрывается,}
    {если был открыт}
    Property ComNumber  : Integer  read  FComNumber
                                   write SetComNumber
                                   stored False;
    {Скорость обмена}
    Property BaudRate  : Cardinal  read  GetBaudRate
                                   write SetBaudRate
                                   stored False;

    {Число бит в байте}
    Property ByteSize  : TByteSize read  GetByteSize
                                   write SetByteSize
                                   stored False;
    {Четность}
    Property Parity    : TParity   read  GetParity
                                   write SetParity
                                   stored False;
    {Число стоп-бит}
    Property Stopbits  : TStopbits read  GetStopbits
                                   write SetStopbits
                                   stored False;
    {Управление линией DTR}
    Property DTR       : Boolean   index 0 read  GetDTRRTS
                                           write SetDTRRTS
                                           stored False;

    {Управление линией DTR}
    Property RTS       : Boolean   index 1 read  GetDTRRTS
                                           write SetDTRRTS
                                           stored False;
    {Управление линией OUT1}
    Property OUT1      : Boolean   index 0 read  GetModemState
                                           write SetModemState
                                           stored False;
    {Управление линией OUT2}
    Property OUT2      : Boolean   index 1 read  GetModemState
                                           write SetModemState
                                           stored False;
 End;

implementation

uses Dialogs;

Type
 TSERIAL_LINE_CONTROL = packed record
  StopBits   : Byte;
  Parity     : Byte;
  WordLength : Byte;
 End;

{Константы для GetCtrlCode} 
Const
 FILE_DEVICE_SERIAL_PORT = $0000001b;
 METHOD_BUFFERED         = 0;
 FILE_ANY_ACCESS         = $0000;
  
function GetCtrlCode(NFunction : Integer): Integer;
begin
  Result:=
     (FILE_DEVICE_SERIAL_PORT shl 16) or
     (FILE_ANY_ACCESS shl 14) or
     (NFunction shl 2) or
     METHOD_BUFFERED;
end;

Function SetByteMask(Value : Cardinal; Mask : Byte; State : Boolean) : Cardinal;
Begin
 If State then begin
  Result:= Value or Mask;
 End else begin
  Result:= Value and ($FF-Mask);
 End;
End;

{Конструктор}
Constructor TComPortOnline.Create(AOwner : TComponent);
Begin
 Inherited Create(AOwner);
 FHandle:= INVALID_HANDLE_VALUE;
 FComNumber:= -1;
End;

{Деструктор}
Destructor  TComPortOnline.Destroy;
Begin
 DoClosePort;
 Inherited Destroy;
End;

{Возвращает состояние соединения}
function TComPortOnline.GetConnected: Boolean;
begin
 Result:= (FHandle <> INVALID_HANDLE_VALUE);
end;

{Открытие порта}
Procedure TComPortOnline.Open;
Begin
 DoOpenPort;
End;

{Закрытие порта}
Procedure TComPortOnline.Close;
Begin
 DoClosePort;
End;

{Установка номера порта}
procedure TComPortOnline.SetComNumber(const Value: Integer);
var Active : Boolean;
begin
 Active:= Connected; {сохраним значение активности порта}
 If Active then DoClosePort; {закрыть порт перед изменением индекса}
 FComNumber:= Value; {устанавливаем новое значение номера порта}
 If Active then DoOpenPort; {открыть порт, если он был открыт}
end;

{открытие порта}
Procedure TComPortOnline.DoOpenPort;
Var ComName : String;
Begin
 If Connected then Exit;

 {Для портов 1..9 можно использовать простые имена COM1..COM9,}
 {но для портов 10-256 надо писать полное имя. Для общности   }
 {будем всегда использовать полное имя порта                  }
 ComName:= Format('\\.\COM%-d', [FComNumber]);

 {Открытие последовательного порта }
 FHandle:= CreateFile(
            PChar(ComName), {передаем имя открываемого порта}
            GENERIC_READ or GENERIC_WRITE, {ресурс для чтения и записи}
            0, { не разделяемый ресурс }
            nil, { Нет атрибутов защиты }
            OPEN_EXISTING, {вернуть ошибку, если ресурс не существует}
            FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, {асинхронный режим доступа}
            0 { Должно быть 0 для COM портов }
           ) ;
End;

{закрытие порта}
Procedure TComPortOnline.DoClosePort;
Begin
 If not Connected then Exit;
 {Освобождение дескриптора порта}
 CloseHandle(FHandle);
 {Сброс дескриптора порта}
 FHandle:= INVALID_HANDLE_VALUE;
End;

{== Get/Set BaudRate}
function TComPortOnline.GetBaudRate : Cardinal;
Var Skip : Cardinal;
begin
 Result:= 0;
 DeviceIoControl(FHandle, GetCtrlCode(20), nil, 0,
                  @Result, SizeOf(Result), Skip, nil);
end;

procedure TComPortOnline.SetBaudRate(const Value: Cardinal);
Var Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(1), @Value, SizeOf(Value),
                 nil, 0, Skip, nil);
end;

function TComPortOnline.GetLineControl(const Index: Integer): Byte;
var L : TSERIAL_LINE_CONTROL; Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(21), nil, 0,
                  @L, SizeOf(L), Skip, nil);
 Case Index of
  0: Result:= L.WordLength;
  1: Result:= L.Parity;
  2: Result:= L.StopBits;
 End;
end;

procedure TComPortOnline.SetLineControl(const Index: Integer;
  const Value: Byte);
var L : TSERIAL_LINE_CONTROL; Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(21), nil, 0,
                  @L, SizeOf(L), Skip, nil);
 Case Index of
  0: L.WordLength:= Value;
  1: L.Parity    := Value;
  2: L.StopBits  := Value;
 End;
 DeviceIoControl(FHandle, GetCtrlCode(3), @L, SizeOf(L),
                 nil, 0, Skip, nil);
end;


function TComPortOnline.GetByteSize: TByteSize;
begin
 Result:= TByteSize(GetLineControl(0)-5);
end;

function TComPortOnline.GetParity: TParity;
begin
 Result:= TParity(GetLineControl(1));
end;

function TComPortOnline.GetStopbits: TStopbits;
begin
 Result:= TStopbits(GetLineControl(2));
end;

procedure TComPortOnline.SetByteSize(const Value: TByteSize);
begin
 SetLineControl(0, Byte(Value)+5);
end;

procedure TComPortOnline.SetParity(const Value: TParity);
begin
 SetLineControl(1, Byte(Value));
end;

procedure TComPortOnline.SetStopbits(const Value: TStopbits);
begin
 SetLineControl(2, Byte(Value));
end;

function TComPortOnline.GetDTRRTS(const Index: Integer): Boolean;
var _DTRRST, Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(30), nil, 0,
                  @_DTRRST, SizeOf(_DTRRST), Skip, nil);
 Case Index of
  0: Result:= (_DTRRST and 1) <> 0; // DTR
  1: Result:= (_DTRRST and 2) <> 0; // RTS
 End;
end;

procedure TComPortOnline.SetDTRRTS(const Index: Integer;
  const Value: Boolean);
var _DTRRST, Skip : Cardinal; Code : Integer;
begin
 If Value then begin
  Case Index of
   0: Code:=  9; // IOCTL_SERIAL_SET_DTR
   1: Code:= 12; // IOCTL_SERIAL_SET_RTS
  End;
 End else begin
  Case Index of
   0: Code:= 10; // IOCTL_SERIAL_CLR_DTR
   1: Code:= 13; // IOCTL_SERIAL_CLR_RTS
  End;
 End;
 DeviceIoControl(FHandle, GetCtrlCode(Code), nil, 0,
                     nil, 0, Skip, nil);
end;

Function TComPortOnline.GetTest : Cardinal;
var Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(37), nil, 0,
                  @Result, SizeOf(Result), Skip, nil);
end;

function TComPortOnline.GetModemState(const Index: Integer): Boolean;
var _MState, Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(37), nil, 0,
                  @_MState, SizeOf(_MState), Skip, nil);
 Case Index of
  0: Result:= (_MState and 4) <> 0; // OUT1
  1: Result:= (_MState and 8) <> 0; // OUT2
 End;
end;

procedure TComPortOnline.SetModemState(const Index: Integer;
  const Value: Boolean);
var _MState, Skip : Cardinal;
begin
 DeviceIoControl(FHandle, GetCtrlCode(37), nil, 0,
                  @_MState, SizeOf(_MState), Skip, nil);
 Case Index of
  0: SetByteMask(_MState, 4, Value); // OUT1
  1: SetByteMask(_MState, 8, Value); // OUT2
 End;
 DeviceIoControl(FHandle, GetCtrlCode(38),@_MState, SizeOf(_MState),
                   nil, 0, Skip, nil);
end;

end.
