Как сделать калькулятор в Delphi?

Delphi - объектно-ориентированный язык программирования, разработанный компанией Borland в 1995 году. Он основан на языке программирования Pascal, но имеет более расширенные возможности и добавлены новые функции.

Как Delphi реализует многоплатформенную разработку?

Delphi является интегрированной средой разработки (IDE), которая позволяет разрабатывать программное обеспечение для различных платформ, включая Windows, macOS, Android и iOS. Delphi достигает многоплатформенности с помощью...

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

Советы » Порты » Ассинхронная связь

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
.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2024 - All Rights Reserved - www.delphirus.com