test_comm.pas

本源码采用spcomm串口控件

unit Test_Comm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SPComm, Menus, ExtCtrls, Buttons;

type
  TSeries_frm = class(TForm)
    Com_set: TComboBox;
    baud_set: TComboBox;
    M: TMemo;
    E: TEdit;
    Comm_Trans: TComm;
    MainMenu: TMainMenu;
    N3: TMenuItem;
    N5: TMenuItem;
    HEX: TCheckBox;
    N2: TMenuItem;
    Timer: TTimer;
    Panel1: TPanel;
    JO: TRadioGroup;
    SJW: TRadioGroup;
    TZW: TRadioGroup;
    Timer_T: TEdit;
    Label1: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    JSjg: TEdit;
    Label6: TLabel;
    DHBH: TSpeedButton;
    N4: TMenuItem;
    CTS_ON: TRadioGroup;
    RTS_SET: TRadioGroup;
    DTR_Set: TRadioGroup;
    N1: TMenuItem;
    procedure Com_setChange(Sender: TObject);
    procedure baud_setChange(Sender: TObject);
    procedure Comm_TransReceiveData(Sender: TObject; Buffer: Pointer;BufferLength: Word);
    procedure Comm_TransReceiveError(Sender: TObject; EventMask: Cardinal);
    procedure Comm_TransModemStateChange(Sender: TObject;
      ModemEvent: Cardinal);
    procedure N3Click(Sender: TObject);
    procedure N5Click(Sender: TObject);
    procedure EKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure HEXClick(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DHBHClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer_TChange(Sender: TObject);
    procedure JSjgChange(Sender: TObject);
    procedure TZWClick(Sender: TObject);
    procedure SJWClick(Sender: TObject);
    procedure JOClick(Sender: TObject);
    procedure Comm_TransRequestHangup(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure RTS_SETClick(Sender: TObject);
    procedure CTS_ONClick(Sender: TObject);
    procedure DTR_SetClick(Sender: TObject);
    procedure N1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Series_frm: TSeries_frm;
  com_str:string='COM1';
  Baud:Dword=9600;
  hex_flag:boolean=false;
  char:string='1,2,3,4,A,B,C,D';
  JY:TParity=none;
  SJ:TByteSize=_8;
  TZ:TStopBits=_1;
  FS_JG,JS_JG:integer;
  CTS:boolean=false;
  DTR:TDtrControl=DtrEnable;
  RTS:TRtsControl=RtsEnable;

implementation

{$R *.DFM}

procedure TSeries_frm.Comm_TransReceiveData(Sender:TObject;Buffer:Pointer;BufferLength:Word);
var
  s,viewstring:string;
  i:integer;
  b:byte;
begin
  if not hex_flag then
    begin
      SetLength(S,BufferLength);
      Move(Buffer^,PChar(S)^,BufferLength);
      M.Lines.Add('Recieve $:'+S+#13+#10);
      M.Invalidate;
    end
  //---------------------------------------十六进制
  else
    begin
      SetLength(S,BufferLength);
      Move(Buffer^,pchar(S)^,BufferLength);
      viewstring:='';
      for i:=1 to bufferlength do
        begin
          b:=byte(pchar(s)[i]);
          viewstring:=viewstring+inttohex(b,2);
        end;
      viewstring:='(H)'+viewstring;
      M.Lines.Add('Recieve $:'+viewstring+#13+#10);
      M.Invalidate;
    end;
  //---------------------------------------
end;


procedure TSeries_frm.Com_setChange(Sender: TObject);
begin
  com_str:=uppercase(Trim(com_set.text));
  Comm_trans.StopComm;
  Comm_trans.CommName:=com_str;
  Comm_trans.StartComm;
end;

procedure TSeries_frm.baud_setChange(Sender: TObject);
begin
  Baud:=DWord(Trim(Baud_set.text));
  Comm_trans.BaudRate:=Baud;
end;

procedure TSeries_frm.Comm_TransReceiveError(Sender: TObject;
  EventMask: Cardinal);
begin
  case EventMask of
    CE_BREAK:messagebox(handle,'The hardware detected a break condition. '+#13+#10+'(no support now)','Series Communications',mb_OK);
    CE_DNS:messagebox(handle,'Windows 95 only:'+#13+#10+' A parallel device is not selected.','Series Communications',mb_OK);
    CE_FRAME:messagebox(handle,'The hardware detected a framing error.','Series Communications',mb_OK);
    CE_IOE:messagebox(handle,'An I/O error occurred during communications with the device.','Series Communications',mb_OK);
    CE_MODE:messagebox(handle,'The requested mode is not supported, or the hFile parameter '+#13+#10+
                         'is invalid. If this value is specified, it is the only '+#13+#10+
                         'valid error.','Series Communications',mb_OK);
    CE_OOP:messagebox(handle,'Windows 95 only: A parallel device signaled that it is out of paper.','Series Communications',mb_OK);
    CE_OVERRUN:messagebox(handle,'A character-buffer overrun has occurred. The next character is lost.','Series Communications',mb_OK);
    CE_PTO:messagebox(handle,'Windows 95 only: A time-out occurred on a parallel device.','Series Communications',mb_OK);
    CE_RXOVER:messagebox(handle,'An input buffer overflow has occurred. There is either no '+#13+#10+
                  'room in the input buffer, or a character was received after'+#13+#10+
                  'the end-of-file (EOF) character.'+#13+#10+
                  '(second condition is impossible happened under Win32)','Series Communications',mb_OK);
    CE_RXPARITY:messagebox(handle,'The hardware detected a parity error. (no support)','Series Communications',mb_OK);
    CE_TXFULL:messagebox(handle,'The application tried to transmit a character, but the '+#13+#10+
                          'output buffer was full. (no support)','Series Communications',mb_OK);
  end;
  Comm_trans.StopComm;
end;

procedure TSeries_frm.Comm_TransModemStateChange(Sender: TObject;
  ModemEvent: Cardinal);
begin
  case ModemEvent of
   ME_CTS:messagebox(handle,'The CTS (clear-to-send) signal has changed '+#13+#10+
                      'state. (support in future, not support now)','Series Communications',mb_OK);
   ME_DSR:messagebox(handle,'The DSR (data-set-ready) signal has changed '+#13+#10+
                      'state. (support in future, not support now)','Series Communications',mb_OK);
   ME_RING:messagebox(handle,'The ring indicator signal was detected.','Series Communications',mb_OK);
   ME_RLSD:messagebox(handle,'The RLSD (receive-line-signal-detect) '+#13+#10+
                       'signal has changed state.','Series Communications',mb_OK);
  end;
end;

procedure TSeries_frm.N3Click(Sender: TObject);
begin
  timer.Enabled:=false;
end;

procedure TSeries_frm.N5Click(Sender: TObject);
begin
  close;
end;

procedure TSeries_frm.EKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var i,z:integer;
    b:byte;
begin
  if key=13 then
    begin
      char:=E.Text;
      if hex_flag then
         begin
         //-----------------------------
         z:=0;
         for i:=1 to length(char) do
           begin
             z:=z+1;
             if z=3 then begin sleep(30);z:=0;end ;
             b:=byte(char[i]);
             if not Comm_trans.WriteCommData(@b,1) then
               begin
                e.Clear;
                e.SetFocus;
                Comm_trans.StopComm;
                messagebox(handle,'发送失败！','Series Communications',mb_OK);
               end;
           end;
          //-----------------------------//十六进制发送
          end
     else
        begin
           if not Comm_Trans.WriteCommData(Pchar(char),length(char)) then
              begin
                e.Clear;
                e.SetFocus;
                Comm_trans.StopComm;
                messagebox(handle,'发送失败！','Series Communications',mb_OK);
              end;
        end;
   end;
end;

procedure TSeries_frm.HEXClick(Sender: TObject);
begin
  if hex.Checked then hex_flag:=true
  else hex_flag:=false;
end;

procedure TSeries_frm.N2Click(Sender: TObject);
begin
  char:=e.Text;
  timer.Enabled:=true;
end;

procedure TSeries_frm.TimerTimer(Sender: TObject);
var i,z:integer;
    b:byte;
begin
  if hex_flag then
    begin
    //-----------------------------
     z:=0;
     m.lines.add('Send Data:>');
     for i:=1 to length(char) do
       begin
         z:=z+1;
         if z=3 then begin sleep(30);z:=0;end ;
         b:=byte(char[i]);
         if not Comm_trans.WriteCommData(@b,1) then
           begin
              messagebox(handle,'发送失败！','Series Communications',mb_OK);
              e.Clear;
              e.SetFocus;
              timer.Enabled:=false;
              Comm_Trans.StopComm;
           end
         else
           begin
            M.Lines.Add(char[i]);
           end;
       end;
     M.lines.add(#13+#10);
    //-----------------------------//十六进制发送
    end
  else
    begin
      if not Comm_Trans.WriteCommData(Pchar(char),length(char)) then
        begin
          messagebox(handle,'发送失败！','Series Communications',mb_OK);
          e.Clear;
          e.SetFocus;
          timer.Enabled:=false;
          Comm_Trans.StopComm;
        end
      else
        begin
          M.Lines.Add('Send Data:>'+char);
          M.lines.add(#13+#10);
          M.Invalidate;
        end;
    end;
end;

procedure TSeries_frm.FormCreate(Sender: TObject);
begin
  com_str:='COM1';
  Baud:=9600;
  hex_flag:=false;
  char:='1,2,3,4,A,B,C,D';
  JY:=none;
  SJ:=_8;
  TZ:=_1;
  FS_JG:=1000;
  JS_JG:=10;
  CTS:=false;
  DTR:=DtrEnable;
  RTS:=RtsEnable;
  Comm_trans.StartComm;
end;

procedure TSeries_frm.DHBHClick(Sender: TObject);
var s:string;
begin
  s:='atdt ' + trim(e.text) + #10#13;     //直接拨号
  if not Comm_Trans.WriteCommData(pchar(s),length(s)) then
     begin
        Comm_Trans.Stopcomm;
        messagebox(handle,'拨号失败！','Series Communications',mb_OK);
     end;
end;

procedure TSeries_frm.FormDestroy(Sender: TObject);
begin
  Comm_Trans.StopComm;
end;

procedure TSeries_frm.Timer_TChange(Sender: TObject);
begin
  FS_JG:=strtoint(trim(Timer_T.text));
  timer.Interval:=FS_JG;
end;

procedure TSeries_frm.JSjgChange(Sender: TObject);
begin
  JS_JG:=strtoint(trim(JSjg.text));
  Comm_trans.ReadIntervalTimeout:=JS_JG;
end;

procedure TSeries_frm.TZWClick(Sender: TObject);
begin
  case TZW.ItemIndex of
    0:TZ:=_1;
    1:TZ:=_1_5;
    2:TZ:=_2;
  end;
  Comm_Trans.StopBits:=TZ;
end;

procedure TSeries_frm.SJWClick(Sender: TObject);
begin
  case SJW.ItemIndex of
    0:SJ:=_5;
    1:SJ:=_6;
    2:SJ:=_7;
    3:SJ:=_8;
  end;
  Comm_Trans.ByteSize:=SJ;
end;

procedure TSeries_frm.JOClick(Sender: TObject);
begin
  case JO.ItemIndex of
    0:JY:=Even;
    1:JY:=Odd;
    2:JY:=None;
    3:JY:=Space;
    4:JY:=Mark;
  end;
  Comm_Trans.Parity:=JY;
end;

procedure TSeries_frm.Comm_TransRequestHangup(Sender: TObject);
begin
  messagebox(handle,'程序异常中断！','Series Communications',mb_OK);
end;

procedure TSeries_frm.N4Click(Sender: TObject);
begin
  M.Clear;
end;

procedure TSeries_frm.RTS_SETClick(Sender: TObject);
begin
  case Rts_set.ItemIndex of
    0: RTS:=RtsEnable;
    1: RTS:=RtsDisable;
    2: RTS:=RtsHandshake;
    3: RTS:=RtsTransmissionAvailable;
  end;
  Comm_Trans.RtsControl:=RTS;
end;

procedure TSeries_frm.CTS_ONClick(Sender: TObject);
begin
  case CTS_ON.ItemIndex of
    0:Cts:=true;
    1:Cts:=false;
  end;
  Comm_Trans.Outx_CtsFlow:=CTS;
end;

procedure TSeries_frm.DTR_SetClick(Sender: TObject);
begin
  case DTR_set.ItemIndex of
   0:DTR:=DtrEnable;
   1:DTR:=DtrDisable;
   2:DTR:=DtrHandshake;
  end;
  Comm_Trans.DtrControl:=DTR;
end;

procedure TSeries_frm.N1Click(Sender: TObject);
begin
 messagebox(handle,  '   Welcome To Use This Tools！   '
            +#13+#10
            +#13+#10+'    CopyRight：SILI 2001/1/8    '
            +#13+#10
            +#13+#10+'      Mail:[e-mail]      ',
            'Series Communicationsm',
            MB_OK);
end;

end.