secomm.~pas

自己做的一个串口系统,也是我的毕业设计,界面功能都显粗糙简单,希望有经验的朋友能给予指教

unit SeComm;

interface

uses
  SysUtils, Classes,Windows,Messages;

const
  COMMESSAGE=WM_USER+1;
type
  TStopBits = (ONESTOPBIT,TWOSTOPBITS,ONE5STOPBITS);
  TParity = (EVENPARITY,NOPARITY,MARKPARITY,ODDPARITY);
  TOnReceiveDataEvent = procedure(Sender: TObject;s: string) of Object;

  TReceiveThread = class(TThread)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    FHanlde   :    THandle;
    FhReceive :    THandle;
    FSyn      :    THandle;
    procedure Execute; override;
  published
    { Published declarations }
  end;
  TSeComm = class(TComponent)
  private
    { Private declarations }
    FHandle   :    THandle;
    FhComm    :    THandle;
    FCommName :    String;
    FBaudRate :    DWORD;
    FByteSize :    byte;
    FStopBits :    TStopBits;
    FParity   :    TParity;
    FSyn      :    THandle;
    FTer      :    Toverlapped;

    FOnReceiveData : TOnReceiveDataEvent;

    procedure SetBaudRate(br: DWORD);
    procedure SetByteSize(bs: byte);
    procedure SetStopBits(sb: TStopBits);
    procedure SetParity(p: TParity);
    procedure Listen;
    procedure Receive(var Message: TMessage);
  protected
    { Protected declarations }
    procedure ReceiveData(s: string);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    procedure OpenComm;
    procedure CloseComm;
    procedure Send(s: string);
    property Handle: THandle read FHandle;
  published
    { Published declarations }
    property CommName: string read FCommName write FCommName;
    property BaudRate: DWORD read FBaudRate write SetBaudRate;
    property ByteSize: byte read FByteSize write SetByteSize;
    property StopBits: TStopBits read FStopBits write SetStopBits;
    property Parity: TParity read FParity write SetParity;
    property OnReceiveData: TOnReceiveDataEvent read FOnReceiveData write FOnReceiveData;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TSeComm]);
end;

constructor TSeComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FhComm:=0;
  FCommName:='COM1';
  FBaudRate:=9600;
  FByteSize:=8;
  FStopBits:=ONESTOPBIT;
  FParity:=NOPARITY;
  FHandle:=0;
  if not (csDesigning in ComponentState) then //非设计时
    FHandle:=AllocateHWnd(Receive);
end;

procedure TSeComm.SetBaudRate(br: DWord);
begin
  if br<>FBaudRate then
    FBaudRate:=br;
end;

procedure TSeComm.SetByteSize(bs: Byte);
begin
  if bs<>FByteSize then
    FByteSize:=bs;
end;

procedure TSeComm.SetStopBits(sb: TStopBits);
begin
  if sb<>FStopBits then
    FStopBits:=sb;
end;

procedure TSeComm.SetParity(p: TParity);
begin
  if p<>FParity then
    FParity:=p;
end;

procedure TSeComm.CloseComm;
begin
  if FhComm<>0 then
    closeHandle(FhComm);
  if FTer.hEvent<>0 then
    closeHandle(FTer.hEvent);
  if FSyn<>0 then
    CloseHandle(FSyn);
end;

procedure TSeComm.Send(s: string);
var
  lrc:LongWord;
begin
  if (FhComm=0) or (s='') then exit; //检查Handle值
    WriteFile(FhComm,PChar(s)^,Length(s), lrc, nil); // 送出数据
end;


procedure TSeComm.OpenComm;
var
  cc:TDCB;
begin
  // 选择所要打开的COM
  FhComm:=CreateFile(PChar(FCommName), GENERIC_READ or GENERIC_WRITE,
       0, nil, OPEN_EXISTING, 0, 0); // 打开COM
  if (FhComm = INVALID_HANDLE_VALUE) then // 如果COM 未打开
  begin
    raise Exception.Create('OpenComm Error!');
  end;

  GetCommState(FhComm,cc); // 得知目前COM 的状态
  cc.BaudRate:=FBaudRate; // 设置波特率
  cc.ByteSize:=FByteSize;  // 设置数据位
  cc.Parity:=byte(FParity); // 设置校验
  cc.StopBits:=byte(FStopBits); // 设置停止位

  if not SetCommState(FhComm, cc) then // 设置COM 的状态
  begin
    CloseHandle(FhComm);
    raise Exception.Create('SetCommState Error!');
  end;
  Listen;
end;

procedure TReceiveThread.Execute;
var
  dwEvtMask,dwTranser: Dword;
  Ok: Boolean;
  Os: Toverlapped;
begin
  FillChar(Os,SizeOf(Os),0);
  Os.hEvent:=CreateEvent(nil,true,false,nil);
  if Os.hEvent=0 then
  begin
    raise Exception.Create('Os.Event Create Error!');
  end;
  if (not SetCommMask(FhReceive,EV_RXCHAR)) then
  begin
    raise Exception.Create('SetCommMask Error!');
  end;
  while (true) do
  begin
    dwEvtMask:=0;
    if not WaitCommEvent(FhReceive,dwEvtMask,@Os) then
    begin
      if ERROR_IO_PENDING=GetLastError then
        GetOverLappedResult(FhReceive,Os,dwTranser,true)
    end;
    if ((dwEvtMask and EV_RXCHAR)=EV_RXCHAR) then
    begin
      WaitForSingleObject(FSyn,INFINITE);
      ResetEvent(FSyn);
      Ok:=PostMessage(FHanlde,COMMESSAGE,FHReceive,0);
      if (not Ok) then
      begin
        raise Exception.Create('PostMessage Error!');
      end;
    end;
  end;
  CloseHandle(Os.hEvent);
end;

procedure TSeComm.Listen;
var
  uir:TReceiveThread;
begin
  FillChar(FTer,Sizeof(FTer),0);
  FTer.Offset:=0;
  FTer.OffsetHigh:=0;
  FTer.hEvent:=CreateEvent(nil,true,false,nil);
  if FTer.hEvent=0 then
  begin
    CloseHandle(FhComm);
    raise Exception.Create('CreateEvent Error!');
  end;
  FSyn:=CreateEvent(nil,true,true,nil);
  if FSyn=0 then
  begin
    CloseHandle(FhComm);
    CloseHandle(FTer.hEvent);
    raise Exception.Create('CreateEvent Error!');
  end;
  uir:=TReceiveThread.Create(true);
  uir.FhReceive := FhComm;
  uir.FSyn := FSyn;
  uir.FHanlde := FHandle;
  uir.Resume;
  EscapeCommFunction(FhComm,SETDTR);
end;

procedure TSeComm.Receive(var Message: TMessage);
var
  Temp : string;
  inbuff: array[0..2047] of Char;
  nBytesRead, dwError:LongWORD ;
  cs:TCOMSTAT;
begin
  if Message.Msg =COMMESSAGE then
  begin
    ClearCommError(FhComm,dwError,@CS);  //取得状态
    if cs.cbInQue > sizeof(inbuff) then // 数据是否大于我们所准备的Buffer
    begin
      PurgeComm(FhComm, PURGE_RXCLEAR);  // 清除COM 数据
      exit;
    end;
    ReadFile(FhComm, inbuff,cs.cbInQue,nBytesRead,nil); // 接收COM 的数据
    Temp:=Copy(inbuff,1,cs.cbInQue); //转移数据到变量中
  end;
end;

procedure TSeComm.ReceiveData(s: string);
begin
  if Assigned(FOnReceiveData) then
     FOnReceiveData(self,s)
end;

end.