unit1.~pas

WAPI串口编程示例,用复杂的api函数,实现的串口功能更为强大.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls,StrUtils, Buttons, ToolWin, ExtCtrls;

const
  WM_COMMNOTIFY = WM_USER + 100; // 通讯消息

type
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    Memo1: TMemo;
    Memo2: TMemo;
    Label1: TLabel;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    ComboBox4: TComboBox;
    ComboBox3: TComboBox;
    ComboBox2: TComboBox;
    ComboBox1: TComboBox;
    Label7: TLabel;
    ComboBox5: TComboBox;
    btnOpenCom: TButton;
    btnSendData: TButton;
    btnReceiveData: TButton;
    btnCloseCom: TButton;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    SpeedButton1: TSpeedButton;
    Timer1: TTimer;
    Button8: TButton;
    Button9: TButton;
    Edit1: TEdit;
    Label2: TLabel;
    procedure btnOpenComClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnCloseComClick(Sender: TObject);
    procedure send(var data:array of byte;len:integer);
    procedure btnReceiveDataClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure btnSendDataClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    procedure WMCOMMNOTIFY(var Message :TMessage);message WM_COMMNOTIFY;
  public
    procedure sendorder(order:string);
    function read():string;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  CommHandle:THandle;
  PostEvent:THandle;
  ReadOs : Toverlapped;
  Connected:Boolean;
  Receive :Boolean;
  ReceiveData : Dword;
  chang:integer;
  
procedure delay(MSecs: Longint);           //延时函数，MSecs单位为毫秒(千分之1秒)
var
    FirstTickCount, Now: Longint;
begin

    FirstTickCount := GetTickCount();
    repeat
        Application.ProcessMessages;
        Now := GetTickCount();
    until (Now - FirstTickCount >= MSecs) or (Now < FirstTickCount);
end;

 //******一位的16转10进制***********///

function hex(c:char):Integer ;
var
      x:integer;
begin
     if c=' ' then
        x:=0
     else if (Ord(c)>=ord('0')) and (Ord(c)<=ord('9')) then
        x:=Ord(c)-Ord('0')
     else if (Ord(c)>=ord('a')) and (Ord(c)<=ord('f')) then
        x:=Ord(c)-Ord('a')+10
     else if (Ord(c)>=ord('A')) and (Ord(c)<=ord('F')) then
        x:=Ord(c)-Ord('A')+10
     else
        x:=-1;//输入错误
      Result:=x;
end;



//******2位的16转10进制***********///

function HexToInt(S:String): Integer;
var
    tmpInt1,tmpInt2:Integer ;
begin
   if Length(S)=1 then
   begin
      Result:=hex(S[1]);
   end
   else if Length(S)=2 then
   begin
      tmpInt1:=hex(S[1]);
      tmpInt2:=hex(S[2]);
      if (tmpInt1=-1) or (tmpInt2=-1) then
          Result:=-1
      else
          Result:= tmpInt1*16+tmpInt2;
      end
    else
        Result:=-1; //输入错误，转换失败
end;



 // *********发送16进制***************//

procedure send16(Output:string);
var
    Len:Integer;
    i,count,tmpInt:Integer;
     tmpVar:Variant;
    tmpStr:String;

begin
         Len:=Length(Output);
         i:=1;
         count:=1;
         tmpVar:=VarArrayCreate([1,1],varByte);//创建一个Variant数组
         while(i<Len) do
         begin
              tmpStr:=Copy(Output,i,2);
              tmpStr:=LowerCase(tmpStr);
              tmpInt:=HexToInt(tmpStr);

              if tmpInt=-1 then
              begin
                  showmessage('发送的数据格式有问题！');
                  exit;
              end
              else
              begin
                  tmpVar[Count]:=tmpInt;
              end;
              i:=i+2;
              if len>i then
              begin
                 Inc(count);
                 VarArrayRedim(tmpVar,count);
              end;
        end;


 end;





// *********接收的数据送入显示区Memo2***************//

procedure AddToMemo(Str:PChar;Len:Dword);
begin

  str[Len]:=#0;//接收厚的字符串为NULL终止
  Form1.Memo2.Text:=Form1.Memo2.Text+StrPas(str);
end;



 // ********通讯监视线程 ************///


procedure CommWatch(Ptr:Pointer);stdcall;
var
  dwEvtMask,dwTranser : Dword;
  PostMsgFlag: Boolean;
  overlapped : Toverlapped;
  CommState : ComStat;
  dwNumberOfBytesRead : Dword;
  ErrorFlag : Dword;
  repVar:array of byte;

  i,n:integer;
  s:string;
begin
  Receive :=True;
  FillChar(overlapped,SizeOf(overlapped),0);
  overlapped.hEvent :=CreateEvent(nil,True,False,nil); // 创建重叠读事件对象
  if overlapped.hEvent=null then
  begin
    MessageBox(0,'overlapped.Event Create Error !','Notice',MB_OK);
    Exit;
  end;

  //进入串口监视状态，直到全局变量Receive置为False停止
  while(Receive) do
  begin

    dwEvtMask:=0;
    // 等待串口事件发生
    if not WaitCommEvent(CommHandle,dwEvtMask,@overlapped) then
    begin
      if ERROR_IO_PENDING=GetLastError then
        GetOverLappedResult(CommHandle,overlapped,dwTranser,True)
      end;


      if ((dwEvtMask and EV_RXCHAR)=EV_RXCHAR) then
      begin

           if not ClearCommError(CommHandle,ErrorFlag,@CommState) then
           begin
               MessageBox(0,'ClearCommError !','Notice',MB_OK);
               PurgeComm(CommHandle,Purge_Rxabort or Purge_Rxclear);
               Exit;
           end;

           if CommState.cbInQue>0 then
           begin
               chang:=CommState.cbInQue;
               setlength(repVar,chang);

               if (not ReadFile( CommHandle,repVar[0],CommState.cbInQue,dwNumberOfBytesRead,@ReadOs )) then
               begin
                   ErrorFlag := GetLastError();
                   if (ErrorFlag <> 0) and (ErrorFlag <> ERROR_IO_PENDING) then
                   begin
                        MessageBox(0,'ReadFile Error!','Notice',MB_OK);
                        Receive :=False;
                        CloseHandle(ReadOs.hEvent);
                        CloseHandle(PostEvent);
                        CloseHandle(CommHandle);
                        Exit;
                  end
                  else begin
                       WaitForSingleObject(CommHandle,INFINITE); // 等待操作完成
                       GetOverlappedResult(CommHandle,ReadOs,dwNumberOfBytesRead,False);
                  end;
              end;
              if dwNumberOfBytesRead>0 then
              begin
                  ReadOs.Offset :=ReadOs.Offset+dwNumberOfBytesRead;
                  ReceiveData := ReadOs.Offset;
                  s:='';
                  for i:=low(repVar) to high(repVar) do
                  begin
                       n:=repVar[i];
                       s:=s+' '+inttohex(n,2);
                  end;

                  form1.Memo2.Text:=form1.Memo2.Text+s;
                  form1.Memo2.SelStart:=length(form1.Memo2.Text);

             end;
          end;
         // CloseHandle(overlapped.hEvent); // 关闭重叠读事件对象
        //WaitForSingleObject(Postevent,INFINITE);

       // ResetEvent(PostEvent);

        //PostMsgFlag:=PostMessage(Form1.Handle,WM_COMMNOTIFY,CommHandle,0);
      {if (not PostMsgFlag) then
        begin
          MessageBox(0,'PostMessage Error !','Notice',MB_OK);
          Exit;
        end; }
      end;
    end;
    CloseHandle(overlapped.hEvent); // 关闭重叠读事件对象
end;



procedure ShowReadData(RVData: byte);
var
 i:integer;
begin
      i:= RVData;
      showmessage(inttostr(i));
end;
// **********消息处理函数*************///



procedure TForm1.WMCOMMNOTIFY(var Message :TMessage);
var
  CommState : ComStat;
  dwNumberOfBytesRead : Dword;
  ErrorFlag : Dword;
  InputBuffer : Array [0..1024] of Char;
  repVar:array of byte;

  i,n:integer;
  s:string;
  tmpVar:Variant;
begin
  if not ClearCommError(CommHandle,ErrorFlag,@CommState) then
  begin
    MessageBox(0,'ClearCommError !','Notice',MB_OK);
    PurgeComm(CommHandle,Purge_Rxabort or Purge_Rxclear);
    Exit;
  end;

  if CommState.cbInQue>0 then
  begin
     chang:=CommState.cbInQue;
     setlength(repVar,chang);

    if (not ReadFile( CommHandle,repVar[0],CommState.cbInQue,dwNumberOfBytesRead,@ReadOs )) then
    begin
      ErrorFlag := GetLastError();
      if (ErrorFlag <> 0) and (ErrorFlag <> ERROR_IO_PENDING) then
      begin
        MessageBox(0,'ReadFile Error!','Notice',MB_OK);
        Receive :=False;
        CloseHandle(ReadOs.hEvent);
        CloseHandle(PostEvent);
        CloseHandle(CommHandle);
        Exit;
      end
      else begin
        WaitForSingleObject(CommHandle,INFINITE); // 等待操作完成
        GetOverlappedResult(CommHandle,ReadOs,dwNumberOfBytesRead,False);
      end;
    end;
    if dwNumberOfBytesRead>0 then
    begin
      ReadOs.Offset :=ReadOs.Offset+dwNumberOfBytesRead;
      ReceiveData := ReadOs.Offset;
      for i:=low(repVar) to high(repVar) do
      begin
          n:=repVar[i];
          s:=s+' '+inttohex(n,2);
      end;
      self.Memo2.Text:=self.Memo2.Text+s;

    end;
  end;
  SetEvent(PostEvent);    // 允许发送下一个WM_COMMNOTIFY消息
end;


procedure TForm1.btnOpenComClick(Sender: TObject);
var
    CommTimeOut : TCOMMTIMEOUTS;
    DCB : TDCB;

begin
    StatusBar1.SimpleText := '连接中...';

    //发送消息的句柄
    PostEvent:=CreateEvent(nil,True,True,nil);
    if PostEvent=null then
    begin
        MessageBox(0,'CreateEvent Error!','Notice',MB_OK);
        StatusBar1.SimpleText := '串口打开失败';
        Exit;
    end;

    //Overlapped Read建立句柄
    ReadOs.hEvent :=CreateEvent(nil,true,False,nil);
    if ReadOs.hEvent=null then
    begin
        MessageBox(0,'CreateEvent Error!','Notice',MB_OK);
        CloseHandle(PostEvent);
        StatusBar1.SimpleText := '串口打开失败';
        Exit;
    end;

    //建立串口句柄
    CommHandle := CreateFile(PChar(ComboBox1.Text),GENERIC_WRITE or GENERIC_READ,
             0,nil,OPEN_EXISTING,FILE_FLAG_OVERLAPPED or FILE_ATTRIBUTE_NORMAL,0);

    if CommHandle = INVALID_HANDLE_VALUE then
    begin
        CloseHandle(PostEvent);
        CloseHandle(ReadOs.hEvent);
        MessageBox(0,'串口打开失败!','Notice',MB_OK);
        StatusBar1.SimpleText := '串口打开失败';
        Exit;
    end;
    StatusBar1.SimpleText := '已同端口 '+ ComboBox1.Text + ' 连接！';

    //设置超时
    CommTimeOut.ReadIntervalTimeout := MAXDWORD;
    CommTimeOut.ReadTotalTimeoutMultiplier := 0;
    CommTimeOut.ReadTotalTimeoutConstant := 0;
    SetCommTimeouts(CommHandle, CommTimeOut);

    //设置读写缓存
    SetupComm(CommHandle,4096,1024);

    //对串口进行指定配置
    GetCommState(CommHandle,DCB);
    DCB.BaudRate := StrToInt(ComboBox2.Text);
    DCB.ByteSize := StrToInt(ComboBox3.Text);
    DCB.Parity := ComboBox4.ItemIndex;;
    DCB.StopBits := ComboBox5.ItemIndex;
    //dcb.fBinary:=true;
    Connected := SetCommState(CommHandle, DCB);


    //关系串口的读事件
    if (not SetCommMask(CommHandle,EV_RXCHAR)) then
    begin
      MessageBox(0,'SetCommMask Error !','Notice',MB_OK);
      Exit;
    end;

    if (Connected) then
    begin
        btnOpenCom.Enabled :=False;
    end
    else begin
        CloseHandle(CommHandle);
        StatusBar1.SimpleText := '设置串口失败';
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    Connected:=False;
    ComboBox1.ItemIndex:=0;
    ComboBox2.ItemIndex:=0;
    ComboBox3.ItemIndex:=4;
    ComboBox4.ItemIndex:=0;
    ComboBox5.ItemIndex:=0;      
end;

procedure TForm1.btnCloseComClick(Sender: TObject);
begin
    if not Connected then
    begin
        StatusBar1.SimpleText := '未打开串口';
        Exit;
    end;
    Receive :=False;
    form1.btnReceiveData.Enabled:=true;
    //取消事件监视，此时监视线程中的WaitCommEvent将返回
    SetCommMask(CommHandle,0);
    //等待监视线程结束
    WaitForSingleObject(PostEvent,INFINITE);
     //关闭事件句柄
    CloseHandle(PostEvent);
    //停止发送和接收数据，并清除发送和接收缓冲区
    PurgeComm(CommHandle,PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
     //关闭其他的句柄
    CloseHandle(ReadOs.hEvent);
    CloseHandle(CommHandle);    
    btnOpenCom.Enabled :=True;
    Connected:=False;
    StatusBar1.SimpleText := '串口已经关闭';
end;

procedure TForm1.send(var data:array of byte;len:integer);
var
    i:Integer;
    writeoverlapped:TOverlapped;
    ByteToWrite,BytesWritten,AllBytesWritten:DWORD;
    ErrorCode,ErrorFlag:DWORD;
    CommStat:COMSTAT;

begin
    ByteToWrite:=len;
    BytesWritten:=1;
    if not Connected then
    begin
        StatusBar1.SimpleText := '未打开串口';
        Exit;
    end;