home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 26 / CD_ASCQ_26_1295.iso / vrac / caterm.zip / CATE.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-20  |  14KB  |  514 lines
  1. unit Cate;
  2.  
  3. interface
  4. uses Messages, WinTypes, WinProcs, Classes, Forms;
  5.  
  6. type
  7.     TPort = (NoPort, Com1, Com2, Com3, Com4, Com5, Com6, Com7, Com8, Com9);
  8.     TBaudRate = (____110, ____300, ____600, ___1200, ___2400, ___4800, ___9600, __14400,
  9.                          __19200, __38400, __56000, _128000, _256000);
  10.     TParity = (None, Odd, Even, Mark, Space);
  11.     TDataBits = (_4, _5, _6, _7, _8);
  12.     TStopBits = (_1, _1_5, _2);
  13.     TCommEvent = (BreakMask, CtsMask, CtssMask, DsrMask, ErrMask, PerrMask, RingMask, RingTEMask,
  14.                             RlsdMask, RlsdsMask, RxCharMask, RxFlagMask, TxEmptyMask);
  15.     TCommEvents = set of TCommEvent;
  16.  
  17. const
  18.     PortDefault = NoPort;
  19.     BaudRateDefault = ___9600;
  20.     ParityDefault = None;
  21.     DataBitsDefault = _8;
  22.     StopBitsDefault = _1;
  23.     ReadBufferSizeDefault = 2048;
  24.     WriteBufferSizeDefault = 2048;
  25.     RxFullDefault = 1024;
  26.     TxLowDefault = 1024;
  27.     EventsDefault = [];
  28.  
  29. type
  30.     TNotifyBreak = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  31.     TNotifyCts = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  32.     TNotifyCtss = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  33.     TNotifyDsr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  34.     TNotifyErr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  35.     TNotifyPErr = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  36.     TNotifyRing = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  37.     TNotifyRlsd = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  38.     TNotifyRlsds = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  39.     TNotifyRxChar = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  40.     TNotifyRxFlag = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  41.     TNotifyTxEmpty = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  42.     TNotifyRingTE = procedure(Sender: TObject; CommEvent:TCommEvents) of object;
  43.     TNotifyReceiveEvent = procedure(Sender: TObject; Count: Word) of object;
  44.     TNotifyTransmitEvent = procedure(Sender: TObject; Count: Word) of object;
  45.  
  46.     TCate= class(TComponent)
  47.     private
  48.         FPort: TPort;
  49.         FBaudRate: TBaudRate;
  50.         FParity: TParity;
  51.         FDataBits: TDataBits;
  52.         FStopBits: TStopBits;
  53.         FReadBufferSize: Word;
  54.         FWriteBufferSize: Word;
  55.         FRxFull: Word;
  56.         FTxLow: Word;
  57.         FEvents: TCommEvents;
  58.  
  59.         FOnBreak: TNotifyBreak;
  60.         FOnCts: TNotifyCts;
  61.         FOnCtss: TNotifyCtss;
  62.         FOnDsr: TNotifyDsr;
  63.         FOnErr: TNotifyErr;
  64.         FOnPErr: TNotifyPErr;
  65.         FOnRing: TNotifyRing;
  66.         FOnRlsd: TNotifyRlsd;
  67.         FOnRlsds: TNotifyRlsds;
  68.         FOnRxChar: TNotifyRxChar;
  69.         FOnRxFlag: TNotifyRxFlag;
  70.         FOnTxEmpty: TNotifyTxEmpty;
  71.         FOnRingTE: TNotifyRingTE;
  72.  
  73.         FOnReceive: TNotifyReceiveEvent;
  74.         FOnTransmit: TNotifyTransmitEvent;
  75.         FWindowHandle: hWnd;
  76.         hComm: Integer;
  77.         HasBeenLoaded: Boolean;
  78.         Error: Boolean;
  79.         {Comm Parameter Set Procedures...}
  80.         procedure SetPort(Value: TPort);
  81.         procedure SetBaudRate(Value: TBaudRate);
  82.         procedure SetParity(Value: TParity);
  83.         procedure SetDataBits(Value: TDataBits);
  84.         procedure SetStopBits(Value: TStopBits);
  85.         procedure SetReadBufferSize(Value: Word);
  86.         procedure SetWriteBufferSize(Value: Word);
  87.         procedure SetRxFull(Value: Word);
  88.         procedure SetTxLow(Value: Word);
  89.         procedure SetEvents(Value: TCommEvents);
  90.         procedure WndProc(var Msg: TMessage);
  91.  
  92.         {WM_COMMNOTIFY Event Procedures...}
  93.         procedure EvReceive;
  94.         procedure EvTransmit;
  95.         procedure CrackEvents;
  96.  
  97.         {WM_COMMNOTIFY sub-events: EV_xxxxx}
  98.         procedure EvBreak;
  99.         procedure EvCts;
  100.         procedure EvCtss;
  101.         procedure EvDsr;
  102.         procedure EvErr;
  103.         procedure EvPErr;
  104.         procedure EvRing;
  105.         procedure EvRlsd;
  106.         procedure EvRlsds;
  107.         procedure EvRxChar;
  108.         procedure EvRxFlag;
  109.         procedure EvTxEmpty;
  110.         procedure EvRingTE;
  111.     protected
  112.         procedure Loaded; override;
  113.     public
  114.         constructor Create(AOwner: TComponent);override;
  115.     destructor Destroy;override;
  116.     procedure Write(Data: PChar;Len: Word);
  117.     procedure Read(Data: PChar;Len: Word);
  118.         function IsError: Boolean;
  119.   published
  120.     property Port: TPort read FPort write SetPort default PortDefault;
  121.         property BaudRate: TBaudRate read FBaudRate write SetBaudRate default BaudRateDefault;
  122.     property Parity: TParity read FParity write SetParity default ParityDefault;
  123.         property DataBits: TDataBits read FDataBits write SetDataBits default DataBitsDefault;
  124.         property StopBits: TStopBits read FStopBits write SetStopBits default StopBitsDefault;
  125.         property WriteBufferSize: Word read FWriteBufferSize write SetWriteBufferSize default WriteBufferSizeDefault;
  126.         property ReadBufferSize: Word read FReadBufferSize write SetReadBufferSize default ReadBufferSizeDefault;
  127.         property RxFullCount: Word read FRxFull write SetRxFull default RxFullDefault;
  128.         property TxLowCount: Word read FTxLow write SetTxLow default TxLowDefault;
  129.         property Events: TCommEvents read FEvents write SetEvents default EventsDefault;
  130.  
  131.         property OnBreak: TNotifyBreak read FOnBreak write FOnBreak;
  132.         property OnCts: TNotifyCts read FOnCts write FOnCts;
  133.         property OnCtss: TNotifyCtss read FOnCtss write FOnCtss;
  134.         property OnDsr: TNotifyDsr read FOnDsr write FOnDsr;
  135.         property OnErr: TNotifyErr read FOnErr write FOnErr;
  136.         property OnPErr: TNotifyPErr read FOnPErr write FOnPErr;
  137.         property OnRing: TNotifyRing read FOnRing write FOnRing;
  138.         property OnRlsd: TNotifyRlsd read FOnRlsd write FOnRlsd;
  139.         property OnRlsds: TNotifyRlsds read FOnRlsds write FOnRlsds;
  140.         property OnRxChar: TNotifyRxChar read FOnRxChar write FOnRxChar;
  141.         property OnRxFlag: TNotifyRxFlag read FOnRxFlag write FOnRxFlag;
  142.         property OnTxEmpty: TNotifyTxEmpty read FOnTxEmpty write FOnTxEmpty;
  143.         property OnRingTE: TNotifyRingTE read FOnRingTE write FOnRingTE;
  144.         property OnReceive: TNotifyReceiveEvent read FOnReceive write FOnReceive;
  145.         property OnTransmit: TNotifyTransmitEvent read FOnTransmit write FOnTransmit;
  146.     end;
  147.  
  148. procedure Register;
  149.  
  150. implementation
  151.  
  152. {************* Property Handlers *************}
  153.  
  154. procedure TCate.SetPort(Value: TPort);
  155. const
  156.     CommStr: PChar= 'COM1:';
  157. begin
  158.     FPort := Value;
  159.     if (csDesigning in ComponentState) or (not HasBeenLoaded) then exit;
  160.     if hComm >= 0 then CloseComm(hComm);        {In case ReadBufferSize or WriteBufferSize is changing}
  161.     if Value= NoPort then exit;
  162.     CommStr[3] := chr(48 + ord(Value));
  163.     hComm := OpenComm(CommStr, ReadBufferSize, WriteBufferSize);
  164.     if hComm < 0 then
  165.     begin
  166.     Error := True;
  167.         exit;
  168.   end;
  169.     SetBaudRate(FBaudRate);
  170.   SetParity(FParity);
  171.     SetDataBits(FDataBits);
  172.     SetStopBits(FStopBits);
  173.     SetEvents(FEvents);
  174.     EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
  175. end;
  176.  
  177. procedure TCate.SetBaudRate(Value: TBaudRate);
  178. var
  179.   DCB: TDCB;
  180. begin
  181.     FBaudRate := Value;
  182.   if hComm >= 0 then
  183.     begin
  184.         GetCommState(hComm, DCB);
  185.         case Value of
  186.             ____110: DCB.BaudRate := CBR_110;
  187.             ____300: DCB.BaudRate := CBR_300;
  188.             ____600: DCB.BaudRate := CBR_600;
  189.             ___1200: DCB.BaudRate := CBR_1200;
  190.             ___2400: DCB.BaudRate := CBR_2400;
  191.             ___4800: DCB.BaudRate := CBR_4800;
  192.             ___9600: DCB.BaudRate := CBR_9600;
  193.             __14400: DCB.BaudRate := CBR_14400;
  194.             __19200: DCB.BaudRate := CBR_19200;
  195.             __38400: DCB.BaudRate := CBR_38400;
  196.             __56000: DCB.BaudRate := CBR_56000;
  197.             _128000: DCB.BaudRate := CBR_128000;
  198.             _256000: DCB.BaudRate := CBR_256000;
  199.     end;
  200.     SetCommState(DCB);
  201.   end;
  202. end;
  203.  
  204. procedure TCate.SetParity(Value: TParity);
  205. var
  206.   DCB: TDCB;
  207. begin
  208.     FParity := Value;
  209.   if hComm < 0 then exit;
  210.   GetCommState(hComm, DCB);
  211.   case Value of
  212.         None: DCB.Parity := 0;
  213.         Odd: DCB.Parity := 1;
  214.         Even: DCB.Parity := 2;
  215.         Mark: DCB.Parity := 3;
  216.         Space: DCB.Parity := 4;
  217.   end;
  218.     SetCommState(DCB);
  219. end;
  220.  
  221. procedure TCate.SetDataBits(Value: TDataBits);
  222. var
  223.   DCB: TDCB;
  224. begin
  225.     FDataBits := Value;
  226.     if hComm < 0 then exit;
  227.     GetCommState(hComm, DCB);
  228.     case Value of
  229.         _4: DCB.ByteSize := 4;
  230.         _5: DCB.ByteSize := 5;
  231.         _6: DCB.ByteSize := 6;
  232.         _7: DCB.ByteSize := 7;
  233.         _8: DCB.ByteSize := 8;
  234.     end;
  235.   SetCommState(DCB);
  236. end;
  237.  
  238. procedure TCate.SetStopBits(Value: TStopBits);
  239. var
  240.     DCB: TDCB;
  241. begin
  242.     FStopBits := Value;
  243.     if hComm < 0 then exit;
  244.     GetCommState(hComm, DCB);
  245.     case Value of
  246.         _1: DCB.StopBits := 0;
  247.         _1_5: DCB.StopBits := 1;
  248.         _2: DCB.StopBits := 2;
  249.   end;
  250.   SetCommState(DCB);
  251. end;
  252.  
  253. procedure TCate.SetReadBufferSize(Value: Word);
  254. begin
  255.     if Value <= 8192 then
  256.     begin
  257.         FReadBufferSize := Value;
  258.     end else
  259.         FReadBufferSize := 8192;
  260.     SetPort(FPort);
  261. end;
  262.  
  263. procedure TCate.SetWriteBufferSize(Value: Word);
  264. begin
  265.     if Value <= 8192 then
  266.     begin
  267.         FWriteBufferSize := Value;
  268.     end else
  269.         FWriteBufferSize := 8192;
  270.     SetPort(FPort);
  271. end;
  272.  
  273. procedure TCate.SetRxFull(Value: Word);
  274. begin
  275.     FRxFull := Value;
  276.   if hComm < 0 then exit;
  277.   EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
  278. end;
  279.  
  280. procedure TCate.SetTxLow(Value: Word);
  281. begin
  282.   FTxLow := Value;
  283.   if hComm < 0 then exit;
  284.   EnableCommNotification(hComm, FWindowHandle, FRxFull, FTxLow);
  285. end;
  286.  
  287. procedure TCate.SetEvents(Value: TCommEvents);
  288. var
  289.   EventMask: Word;
  290. begin
  291.     FEvents := Value;
  292.     if hComm < 0 then exit;
  293.     EventMask := 0;
  294.     if BreakMask in FEvents then inc(EventMask, EV_BREAK);
  295.     if CtsMask in FEvents then inc(EventMask, EV_CTS);
  296.     if CtssMask in FEvents then inc(EventMask, EV_CTSS);
  297.     if DsrMask in FEvents then inc(EventMask, EV_DSR);
  298.     if ErrMask in FEvents then inc(EventMask, EV_ERR);
  299.     if PErrMask in FEvents then inc(EventMask, EV_PERR);
  300.     if RingMask in FEvents then inc(EventMask, EV_RING);
  301.     if RlsdMask in FEvents then inc(EventMask, EV_RLSD);
  302.     if RlsdsMask in FEvents then inc(EventMask, EV_RLSDS);
  303.     if RxCharMask in FEvents then inc(EventMask, EV_RXCHAR);
  304.     if RxFlagMask in FEvents then inc(EventMask, EV_RXFLAG);
  305.     if TxEmptyMask in FEvents then inc(EventMask, EV_TXEMPTY);
  306.     if RingTEMask in FEvents then inc(EventMask, EV_RINGTE);
  307.     SetCommEventMask(hComm, EventMask);
  308. end;
  309.  
  310. {************* Event Handlers *************}
  311.  
  312. procedure TCate.WndProc(var Msg: TMessage);
  313. begin
  314.     with Msg do
  315.     begin
  316.         if Msg= WM_COMMNOTIFY then
  317.         begin
  318.             case lParamLo of
  319.                 CN_EVENT: CrackEvents;
  320.                 CN_RECEIVE: EvReceive;
  321.                 CN_TRANSMIT: EvTransmit;
  322.             end;
  323.         end
  324.         else
  325.             Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  326.     end;
  327. end;
  328.  
  329. procedure TCate.CrackEvents;
  330. var
  331.     EventMask:Word;
  332. begin
  333.     EventMask:=GetCommEventMask(hComm,Integer($FFFF));
  334.  
  335.     if (BreakMask in Events) and (EventMask and EV_BREAK <> 0) then
  336.         EvBreak;
  337.     if (CtsMask in Events) and (EventMask and EV_CTS <> 0) then
  338.         EvCts;
  339.     if (CtssMask in Events) and (EventMask and EV_CTSS <> 0) then
  340.         EvCtss;
  341.     if (DsrMask in Events) and (EventMask and EV_DSR <> 0) then
  342.         EvDsr;
  343.     if (ErrMask in Events) and (EventMask and EV_ERR <> 0) then
  344.         EvErr;
  345.     if (PErrMask in Events) and (EventMask and EV_PERR <> 0) then
  346.             EvPErr;
  347.     if (RingMask in Events) and (EventMask and EV_RING <> 0) then
  348.         EvRing;
  349.     if (RlsdMask in Events) and (EventMask and EV_RLSD <> 0) then
  350.         EvRlsd;
  351.     if (RlsdsMask in Events) and (EventMask and EV_RLSDS <> 0) then
  352.         EvRlsds;
  353.     if (RxCharMask in Events) and (EventMask and EV_RXCHAR <> 0) then
  354.         EvRxChar;
  355.     if (RxFlagMask in Events) and (EventMask and EV_RXFLAG <> 0) then
  356.         EvRxFlag;
  357.     if (TxEmptyMask in Events) and (EventMask and EV_TXEMPTY <> 0) then
  358.         EvTxEmpty;
  359.     if (RingTEMask in Events) and (EventMask and EV_RINGTE <> 0) then
  360.         EvRingTE;
  361. end;
  362.  
  363. procedure TCate.EvBreak;
  364. begin
  365.     if Assigned(FOnBreak) then FOnBreak(Self, Events);
  366. end;
  367.  
  368. procedure TCate.EvCts;
  369. begin
  370.     if Assigned(FOnCts) then FOnCts(Self, Events);
  371. end;
  372.  
  373. procedure TCate.EvCtss;
  374. begin
  375.     if Assigned(FOnCtss) then FOnCtss(Self, Events);
  376. end;
  377.  
  378. procedure TCate.EvDsr;
  379. begin
  380.     if Assigned(FOnDsr) then FOnDsr(Self, Events);
  381. end;
  382.  
  383. procedure TCate.EvErr;
  384. begin
  385.     if Assigned(FOnErr) then FOnErr(Self, Events);
  386. end;
  387.  
  388. procedure TCate.EvPErr;
  389. begin
  390.     if Assigned(FOnPErr) then FOnPErr(Self, Events);
  391. end;
  392.  
  393. procedure TCate.EvRing;
  394. begin
  395.     if Assigned(FOnRing) then FOnRing(Self, Events);
  396. end;
  397.  
  398. procedure TCate.EvRlsd;
  399. begin
  400.     if Assigned(FOnRlsd) then FOnRlsd(Self, Events);
  401. end;
  402.  
  403. procedure TCate.EvRlsds;
  404. begin
  405.     if Assigned(FOnRlsds) then FOnRlsds(Self, Events);
  406. end;
  407.  
  408. procedure TCate.EvRxChar;
  409. begin
  410.     if Assigned(FOnRxChar) then FOnRxChar(Self, Events);
  411. end;
  412.  
  413. procedure TCate.EvRxFlag;
  414. begin
  415.     if Assigned(FOnRxFlag) then FOnRxFlag(Self, Events);
  416. end;
  417.  
  418. procedure TCate.EvTxEmpty;
  419. begin
  420.     if Assigned(FOnTxEmpty) then FOnTxEmpty(Self, Events);
  421. end;
  422.  
  423. procedure TCate.EvRingTE;
  424. begin
  425.     if Assigned(FOnRingTE) then FOnRingTE(Self, Events);
  426. end;
  427.  
  428. procedure TCate.EvReceive;
  429. var
  430.     Stat: TComStat;
  431. begin
  432.     if (hComm < 0) or not Assigned(FOnReceive) then exit;
  433.     GetCommError(hComm, Stat);
  434.     FOnReceive(Self, Stat.cbInQue);
  435.     GetCommError(hComm, Stat);
  436. end;
  437.  
  438. procedure TCate.EvTransmit;
  439. var
  440.     Stat: TComStat;
  441. begin
  442.     if (hComm < 0) or not Assigned(FOnTransmit) then exit;
  443.     GetCommError(hComm, Stat);
  444.     FOnTransmit(Self, Stat.cbOutQue);
  445. end;
  446.  
  447. procedure TCate.Loaded;
  448. begin
  449.     inherited Loaded;
  450.     HasBeenLoaded := True;
  451.     SetPort(FPort);
  452. end;
  453.  
  454.  
  455. constructor TCate.Create(AOwner: TComponent);
  456. begin
  457.     inherited Create(AOwner);
  458.     FWindowHandle := AllocateHWnd(WndProc);
  459.     HasBeenLoaded := False;
  460.     Error := False;
  461.   FPort := PortDefault;
  462.   FBaudRate := BaudRateDefault;
  463.   FParity := ParityDefault;
  464.     FDataBits := DataBitsDefault;
  465.   FStopBits := StopBitsDefault;
  466.   FWriteBufferSize := WriteBufferSizeDefault;
  467.   FReadBufferSize := ReadBufferSizeDefault;
  468.   FRxFull := RxFullDefault;
  469.   FTxLow := TxLowDefault;
  470.   FEvents := EventsDefault;
  471.     hComm := -1;
  472. end;
  473.  
  474. destructor TCate.Destroy;
  475. begin
  476.   DeallocatehWnd(FWindowHandle);
  477.     if hComm >= 0 then CloseComm(hComm);
  478.   inherited Destroy;
  479. end;
  480.  
  481. procedure TCate.Write(Data: PChar;Len: Word);
  482. begin
  483.   if hComm < 0 then exit;
  484.   if WriteComm(hComm, Data, Len) < 0 then Error := True;
  485.   GetCommEventMask(hComm, Integer($FFFF));
  486. end;
  487.  
  488. procedure TCate.Read(Data: PChar;Len: Word);
  489. begin
  490.   if hComm < 0 then exit;
  491.     if ReadComm(hComm, Data, Len) < 0 then Error := True;
  492.     GetCommEventMask(hComm, Integer($FFFF));
  493. end;
  494.  
  495. function TCate.IsError: Boolean;
  496. begin
  497.   IsError := Error;
  498.     Error := False;
  499. end;
  500.  
  501. procedure Register;
  502. begin
  503.     RegisterComponents('System', [TCate]);
  504. end;
  505.  
  506. end.
  507.  
  508.  
  509.  
  510.  
  511.  
  512.  
  513.  
  514.