comm.~pa

delphi1 的串口通讯控件

unit Comm;

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

type
{            Port     : Byte;{0..8;}
{            DataBits : Byte;{5..8;}
{            BaudRate : Byte;{0..12;}{(110,300,600,1200,2400,4800,9600,14400,19200,38400,56000,128000,256000);}
{            Parity   : Byte;{0..4;}{tpNone,tpOdd,tpEven,tpMark,tpSpace}
{            StopBits : Byte;{0..2;}{('1','1.5','2'); }
  TPort= 0..8;
  TBaudRate= 0..12;
  TParity= 0..4;
  TDataBits= 5..8;
  TStopBits= 0..2;
  TCommEvent=(tceBreak,tceCts,tceCtss,tceDsr,tceErr,tcePErr,tceRing,tceRlsd,
              tceRlsds,tceRxChar,tceRxFlag,tceTxEmpty);
  TCommEvents=set of TCommEvent;

const
  PortDefault= 1;
  BaudRateDefault= 6;
  ParityDefault= 0;
  DataBitsDefault= 8;
  StopBitsDefault= 1;
  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
     (not HasBeenLoaded) then exit;
  if hComm>=0 then CloseComm(hComm);
  if Value= 0 then exit;
  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
      0:DCB.BaudRate:=CBR_110;
      1:DCB.BaudRate:=CBR_300;
      2:DCB.BaudRate:=CBR_600;
      3:DCB.BaudRate:=CBR_1200;
      4:DCB.BaudRate:=CBR_2400;
      5:DCB.BaudRate:=CBR_4800;
      6:DCB.BaudRate:=CBR_9600;
      7:DCB.BaudRate:=CBR_14400;
      8:DCB.BaudRate:=CBR_19200;
      9:DCB.BaudRate:=CBR_38400;
      10:DCB.BaudRate:=CBR_56000;
      11:DCB.BaudRate:=CBR_128000;
      12: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);
  DCB.Parity:= Value;
{  case Value of
    None:DCB.Parity:=0;
    Odd:DCB.Parity:=1;
    Even:DCB.Parity:=2;
    Mark:DCB.Parity:=3;
    Space: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);
  DCB.ByteSize:= Value;
  {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);
  DCB.StopBits:= Value;
  {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.