Delphi World - Ассинхронная связь
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Ассинхронная связь

Oдна барышня звонила на какую-то фирму и ругалась, что они ей какой-то не такой софт подсунули, что он не инсталлируется, хотя она все, мол, делает в соответствии с инструкцией (а софт ентот с дискет ставился). Ну, послали спеца из фирмы, продавшей этот софт, на месте разобраться what's, собственно, up... Приехал он, а барышня ему и говорит:
- Вот у вас в инструкции написано - "вставьте дискету #1", ну я вставила, потом написано вставить дискету #2, ну,- говорит, - я ее вставила, потом - дискету #3, ну вставила я ее (с трудом, правда), но вот дискета #4 уже просто в дисковод не лезет!!!


unit Comm;

interface
uses
  Messages, WinTypes, WinProcs, Classes, Forms;

type

  TPort = (tptNone, tptOne, tptTwo, tptThree, tptFour, tptFive, tptSix,
    tptSeven,
    tptEight);
  TBaudRate = (tbr110, tbr300, tbr600, tbr1200, tbr2400, tbr4800, tbr9600,
    tbr14400,
    tbr19200, tbr38400, tbr56000, tbr128000, tbr256000);
  TParity = (tpNone, tpOdd, tpEven, tpMark, tpSpace);
  TDataBits = (tdbFour, tdbFive, tdbSix, tdbSeven, tdbEight);
  TStopBits = (tsbOne, tsbOnePointFive, tsbTwo);
  TCommEvent = (tceBreak, tceCts, tceCtss, tceDsr, tceErr, tcePErr, tceRing,
    tceRlsd,
    tceRlsds, tceRxChar, tceRxFlag, tceTxEmpty);
  TCommEvents = set of TCommEvent;

const

  PortDefault = tptNone;
  BaudRateDefault = tbr9600;
  ParityDefault = tpNone;
  DataBitsDefault = tdbEight;
  StopBitsDefault = tsbOne;
  ReadBufferSizeDefault = 2048;
  WriteBufferSizeDefault = 2048;
  RxFullDefault = 1024;
  TxLowDefault = 1024;
  EventsDefault = [];

type

  TNotifyEventEvent = procedure(Sender: TObject; CommEvent: TCommEvents) of
    object;
  TNotifyReceiveEvent = procedure(Sender: TObject; Count: Word) of object;
  TNotifyTransmitEvent = procedure(Sender: TObject; Count: Word) of object;

  TComm = class(TComponent)
  private
    FPort: TPort;
    FBaudRate: TBaudRate;
    FParity: TParity;
    FDataBits: TDataBits;
    FStopBits: TStopBits;
    FReadBufferSize: Word;
    FWriteBufferSize: Word;
    FRxFull: Word;
    FTxLow: Word;
    FEvents: TCommEvents;
    FOnEvent: TNotifyEventEvent;
    FOnReceive: TNotifyReceiveEvent;
    FOnTransmit: TNotifyTransmitEvent;
    FWindowHandle: hWnd;
    hComm: Integer;
    HasBeenLoaded: Boolean;
    Error: Boolean;
    procedure SetPort(Value: TPort);
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetParity(Value: TParity);
    procedure SetDataBits(Value: TDataBits);
    procedure SetStopBits(Value: TStopBits);
    procedure SetReadBufferSize(Value: Word);
    procedure SetWriteBufferSize(Value: Word);
    procedure SetRxFull(Value: Word);
    procedure SetTxLow(Value: Word);
    procedure SetEvents(Value: TCommEvents);
    procedure WndProc(var Msg: TMessage);
    procedure DoEvent;
    procedure DoReceive;
    procedure DoTransmit;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Write(Data: PChar; Len: Word);
    procedure Read(Data: PChar; Len: Word);
    function IsError: Boolean;
  published
    property Port: TPort read FPort write SetPort default PortDefault;
    property BaudRate: TBaudRate read FBaudRate write SetBaudRate
      default BaudRateDefault;
    property Parity: TParity read FParity write SetParity default ParityDefault;
    property DataBits: TDataBits read FDataBits write SetDataBits
      default DataBitsDefault;
    property StopBits: TStopBits read FStopBits write SetStopBits
      default StopBitsDefault;
    property WriteBufferSize: Word read FWriteBufferSize
      write SetWriteBufferSize default WriteBufferSizeDefault;
    property ReadBufferSize: Word read FReadBufferSize
      write SetReadBufferSize default ReadBufferSizeDefault;
    property RxFullCount: Word read FRxFull write SetRxFull
      default RxFullDefault;
    property TxLowCount: Word read FTxLow write SetTxLow default TxLowDefault;
    property Events: TCommEvents read FEvents write SetEvents
      default EventsDefault;
    property OnEvent: TNotifyEventEvent read FOnEvent write FOnEvent;
    property OnReceive: TNotifyReceiveEvent read FOnReceive write FOnReceive;
    property OnTransmit: TNotifyTransmitEvent read FOnTransmit write
      FOnTransmit;
  end;

procedure Register;

implementation

procedure TComm.SetPort(Value: TPort);
const

  CommStr: PChar = 'COM1:';
begin

  FPort := Value;
  if (csDesigning in ComponentState) or
    (Value = tptNone) or (not HasBeenLoaded) then
    exit;
  if hComm >= 0 then
    CloseComm(hComm);
  CommStr[3] := chr(48 + ord(Value));
  hComm := OpenComm(CommStr, ReadBufferSize, WriteBufferSize);
  if hComm < 0 then
  begin
    Error := True;
    exit;
  end;
  SetBaudRate(FBaudRate);
  SetParity(FParity);
  SetDataBits(FDataBits);
  SetStopBits(FStopBits);
  SetEvents(FEvents);
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetBaudRate(Value: TBaudRate);
var

  DCB: TDCB;
begin

  FBaudRate := Value;
  if hComm >= 0 then
  begin
    GetCommState(hComm, DCB);
    case Value of
      tbr110: DCB.BaudRate := CBR_110;
      tbr300: DCB.BaudRate := CBR_300;
      tbr600: DCB.BaudRate := CBR_600;
      tbr1200: DCB.BaudRate := CBR_1200;
      tbr2400: DCB.BaudRate := CBR_2400;
      tbr4800: DCB.BaudRate := CBR_4800;
      tbr9600: DCB.BaudRate := CBR_9600;
      tbr14400: DCB.BaudRate := CBR_14400;
      tbr19200: DCB.BaudRate := CBR_19200;
      tbr38400: DCB.BaudRate := CBR_38400;
      tbr56000: DCB.BaudRate := CBR_56000;
      tbr128000: DCB.BaudRate := CBR_128000;
      tbr256000: DCB.BaudRate := CBR_256000;
    end;
    SetCommState(DCB);
  end;
end;

procedure TComm.SetParity(Value: TParity);
var

  DCB: TDCB;
begin

  FParity := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tpNone: DCB.Parity := 0;
    tpOdd: DCB.Parity := 1;
    tpEven: DCB.Parity := 2;
    tpMark: DCB.Parity := 3;
    tpSpace: DCB.Parity := 4;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetDataBits(Value: TDataBits);
var

  DCB: TDCB;
begin

  FDataBits := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tdbFour: DCB.ByteSize := 4;
    tdbFive: DCB.ByteSize := 5;
    tdbSix: DCB.ByteSize := 6;
    tdbSeven: DCB.ByteSize := 7;
    tdbEight: DCB.ByteSize := 8;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetStopBits(Value: TStopBits);
var

  DCB: TDCB;
begin

  FStopBits := Value;
  if hComm < 0 then
    exit;
  GetCommState(hComm, DCB);
  case Value of
    tsbOne: DCB.StopBits := 0;
    tsbOnePointFive: DCB.StopBits := 1;
    tsbTwo: DCB.StopBits := 2;
  end;
  SetCommState(DCB);
end;

procedure TComm.SetReadBufferSize(Value: Word);
begin

  FReadBufferSize := Value;
  SetPort(FPort);
end;

procedure TComm.SetWriteBufferSize(Value: Word);
begin

  FWriteBufferSize := Value;
  SetPort(FPort);
end;

procedure TComm.SetRxFull(Value: Word);
begin

  FRxFull := Value;
  if hComm < 0 then
    exit;
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetTxLow(Value: Word);
begin

  FTxLow := Value;
  if hComm < 0 then
    exit;
  EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
end;

procedure TComm.SetEvents(Value: TCommEvents);
var

  EventMask: Word;
begin

  FEvents := Value;
  if hComm < 0 then
    exit;
  EventMask := 0;
  if tceBreak in FEvents then
    inc(EventMask, EV_BREAK);
  if tceCts in FEvents then
    inc(EventMask, EV_CTS);
  if tceCtss in FEvents then
    inc(EventMask, EV_CTSS);
  if tceDsr in FEvents then
    inc(EventMask, EV_DSR);
  if tceErr in FEvents then
    inc(EventMask, EV_ERR);
  if tcePErr in FEvents then
    inc(EventMask, EV_PERR);
  if tceRing in FEvents then
    inc(EventMask, EV_RING);
  if tceRlsd in FEvents then
    inc(EventMask, EV_RLSD);
  if tceRlsds in FEvents then
    inc(EventMask, EV_RLSDS);
  if tceRxChar in FEvents then
    inc(EventMask, EV_RXCHAR);
  if tceRxFlag in FEvents then
    inc(EventMask, EV_RXFLAG);
  if tceTxEmpty in FEvents then
    inc(EventMask, EV_TXEMPTY);
  SetCommEventMask(hComm, EventMask);
end;

procedure TComm.WndProc(var Msg: TMessage);
begin

  with Msg do
  begin
    if Msg = WM_COMMNOTIFY then
    begin
      case lParamLo of
        CN_EVENT: DoEvent;
        CN_RECEIVE: DoReceive;
        CN_TRANSMIT: DoTransmit;
      end;
    end
    else
      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  end;
end;

procedure TComm.DoEvent;
var

  CommEvent: TCommEvents;
  EventMask: Word;
begin

  if (hComm < 0) or not Assigned(FOnEvent) then
    exit;
  EventMask := GetCommEventMask(hComm, Integer($FFFF));
  CommEvent := [];
  if (tceBreak in Events) and (EventMask and EV_BREAK <> 0) then
    CommEvent := CommEvent + [tceBreak];
  if (tceCts in Events) and (EventMask and EV_CTS <> 0) then
    CommEvent := CommEvent + [tceCts];
  if (tceCtss in Events) and (EventMask and EV_CTSS <> 0) then
    CommEvent := CommEvent + [tceCtss];
  if (tceDsr in Events) and (EventMask and EV_DSR <> 0) then
    CommEvent := CommEvent + [tceDsr];
  if (tceErr in Events) and (EventMask and EV_ERR <> 0) then
    CommEvent := CommEvent + [tceErr];
  if (tcePErr in Events) and (EventMask and EV_PERR <> 0) then
    CommEvent := CommEvent + [tcePErr];
  if (tceRing in Events) and (EventMask and EV_RING <> 0) then
    CommEvent := CommEvent + [tceRing];
  if (tceRlsd in Events) and (EventMask and EV_RLSD <> 0) then
    CommEvent := CommEvent + [tceRlsd];
  if (tceRlsds in Events) and (EventMask and EV_Rlsds <> 0) then
    CommEvent := CommEvent + [tceRlsds];
  if (tceRxChar in Events) and (EventMask and EV_RXCHAR <> 0) then
    CommEvent := CommEvent + [tceRxChar];
  if (tceRxFlag in Events) and (EventMask and EV_RXFLAG <> 0) then
    CommEvent := CommEvent + [tceRxFlag];
  if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY <> 0) then
    CommEvent := CommEvent + [tceTxEmpty];
  FOnEvent(Self, CommEvent);
end;

procedure TComm.DoReceive;
var

  Stat: TComStat;
begin

  if (hComm < 0) or not Assigned(FOnReceive) then
    exit;
  GetCommError(hComm, Stat);
  FOnReceive(Self, Stat.cbInQue);
  GetCommError(hComm, Stat);
end;

procedure TComm.DoTransmit;
var
  Stat: TComStat;
begin
  if (hComm < 0) or not Assigned(FOnTransmit) then
    exit;
  GetCommError(hComm, Stat);
  FOnTransmit(Self, Stat.cbOutQue);
end;

procedure TComm.Loaded;
begin
  inherited Loaded;
  HasBeenLoaded := True;
  SetPort(FPort);
end;

constructor TComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWindowHandle := AllocateHWnd(WndProc);
  HasBeenLoaded := False;
  Error := False;
  FPort := PortDefault;
  FBaudRate := BaudRateDefault;
  FParity := ParityDefault;
  FDataBits := DataBitsDefault;
  FStopBits := StopBitsDefault;
  FWriteBufferSize := WriteBufferSizeDefault;
  FReadBufferSize := ReadBufferSizeDefault;
  FRxFull := RxFullDefault;
  FTxLow := TxLowDefault;
  FEvents := EventsDefault;
  hComm := -1;
end;

destructor TComm.Destroy;
begin
  DeallocatehWnd(FWindowHandle);
  if hComm >= 0 then
    CloseComm(hComm);
  inherited Destroy;
end;

procedure TComm.Write(Data: PChar; Len: Word);
begin
  if hComm < 0 then
    exit;
  if WriteComm(hComm, Data, Len) < 0 then
    Error := True;
  GetCommEventMask(hComm, Integer($FFFF));
end;

procedure TComm.Read(Data: PChar; Len: Word);
begin
  if hComm < 0 then
    exit;
  if ReadComm(hComm, Data, Len) < 0 then
    Error := True;
  GetCommEventMask(hComm, Integer($FFFF));
end;

function TComm.IsError: Boolean;
begin
  IsError := Error;
  Error := False;
end;

procedure Register;
begin
  RegisterComponents('Additional', [TComm]);
end;

end.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования