Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 8 мая!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Ассинхронная связь

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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS