fcomm.pas

这是用Delphi+spcomm开发的基于MODBUS协议的RTU程序

unit fcomm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SPComm, ExtCtrls,Radix, ComCtrls, Menus;

type
   bytearray= array of BYTE  ;
  TForm1 = class(TForm)
    Comm1: TComm;
    Edit1: TEdit;
    Timer1: TTimer;
    Button7: TButton;
    Button8: TButton;
    Button9: TButton;
    Label8: TLabel;
    Label11: TLabel;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label2: TLabel;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    Button5: TButton;
    Edit9: TEdit;
    label9: TLabel;
    Label1: TLabel;
    Edit7: TEdit;
    Edit8: TEdit;
    Label7: TLabel;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    StatusBar1: TStatusBar;
    GroupBox3: TGroupBox;
    RichEdit1: TRichEdit;
    Button6: TButton;
    Button4: TButton;
    Button1: TButton;
    GroupBox4: TGroupBox;
    Button2: TButton;
    Button3: TButton;
    Button10: TButton;
    Button11: TButton;
    Edit10: TEdit;
    Timer2: TTimer;
    Button12: TButton;
    Button13: TButton;
    Button14: TButton;
    PopupMenu1: TPopupMenu;
    copy: TMenuItem;
    paste1: TMenuItem;
    selectall1: TMenuItem;
    find1: TMenuItem;
    FindDialog1: TFindDialog;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
      BufferLength: Word);
    procedure Button3Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Edit2Exit(Sender: TObject);
    procedure Edit3Exit(Sender: TObject);
    procedure Edit4Exit(Sender: TObject);
    procedure Edit5Exit(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Edit10Change(Sender: TObject);
    procedure Button11Click(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure Button13Click(Sender: TObject);
    procedure Button12Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure FindDialog1Find(Sender: TObject);
    procedure find1Click(Sender: TObject);
    procedure copyClick(Sender: TObject);
    procedure paste1Click(Sender: TObject);
    procedure selectall1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
 
  end;

var
  Form1: TForm1;
  viewstring:string;
  length1, i,j,k:integer;
  rbuf:array[ 1..1000 ]of byte ;
  crcfunt,crcstart:Cardinal;//初始值
  arrayfun:array of byte;

const

  sbuf:array[ 1..10 ]of byte =( $01,$04,$10,$00,$00,$09,$34,$cc,0,0 );

  tablecrchi:array[ 0..255 ] of byte=(
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $00, $C1, $81, $40, $01, $C0,
$80, $41, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $00, $C1,
$81, $40, $01, $C0, $80, $41, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $00, $C1,
$81, $40, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $01, $C0, $80, $41, $00, $C1,
$81, $40, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $00, $C1, $81, $40, $01, $C0,
$80, $41, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $00, $C1, $81, $40, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$01, $C0, $80, $41, $00, $C1, $81, $40, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $01, $C0, $80, $41, $00, $C1,
$81, $40, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40
 );
     tablecrclow:array[ 0..255 ] of byte= (
$00, $C0, $C1, $01, $C3, $03, $02, $C2, $C6, $06,
$07, $C7, $05, $C5, $C4, $04, $CC, $0C, $0D, $CD,
$0F, $CF, $CE, $0E, $0A, $CA, $CB, $0B, $C9, $09,
$08, $C8, $D8, $18, $19, $D9, $1B, $DB, $DA, $1A,
$1E, $DE, $DF, $1F, $DD, $1D, $1C, $DC, $14, $D4,
$D5, $15, $D7, $17, $16, $D6, $D2, $12, $13, $D3,
$11, $D1, $D0, $10, $F0, $30, $31, $F1, $33, $F3,
$F2, $32, $36, $F6, $F7, $37, $F5, $35, $34, $F4,
$3C, $FC, $FD, $3D, $FF, $3F, $3E, $FE, $FA, $3A,
$3B, $FB, $39, $F9, $F8, $38, $28, $E8, $E9, $29,
$EB, $2B, $2A, $EA, $EE, $2E, $2F, $EF, $2D, $ED,
$EC, $2C, $E4, $24, $25, $E5, $27, $E7, $E6, $26,
$22, $E2, $E3, $23, $E1, $21, $20, $E0, $A0, $60,
$61, $A1, $63, $A3, $A2, $62, $66, $A6, $A7, $67,
$A5, $65, $64, $A4, $6C, $AC, $AD, $6D, $AF, $6F,
$6E, $AE, $AA, $6A, $6B, $AB, $69, $A9, $A8, $68,
$78, $B8, $B9, $79, $BB, $7B, $7A, $BA, $BE, $7E,
$7F, $BF, $7D, $BD, $BC, $7C, $B4, $74, $75, $B5,
$77, $B7, $B6, $76, $72, $B2, $B3, $73, $B1, $71,
$70, $B0, $50, $90, $91, $51, $93, $53, $52, $92,
$96, $56, $57, $97, $55, $95, $94, $54, $9C, $5C,
$5D, $9D, $5F, $9F, $9E, $5E, $5A, $9A, $9B, $5B,
$99, $59, $58, $98, $88, $48, $49, $89, $4B, $8B,
$8A, $4A, $4E, $8E, $8F, $4F, $8D, $4D, $4C, $8C,
$44, $84, $85, $45, $87, $47, $46, $86, $82, $42,
$43, $83, $41, $81, $80, $40
  ) ;

implementation

uses  comset;
//function ShellExecute(hwnd:integer;ss,ss2,s3,s4:pchar;dd:integer  ):integer; external 'shell32.dll' name 'ShellExecute';

{$R *.dfm}

function tablecrc16(var crcstart1:Cardinal;crcfunt1:Cardinal; bytearray1:array of byte; const bytelength:integer ):word ;
var
  I : Integer ;
 iindex,j:integer;
 crchi,crclo:integer;
  
begin
     j:=0;

    crchi:=hi( crcstart1 ) ;
    crclo:=lo( crcstart1 ) ;
   // setlength( bytearray1,bytelength ) ;

 for I := 0 to bytelength-1
 do    // Iterate
   begin
     iindex:=crchi xor bytearray1[j] ;
     crchi:=crclo xor  tablecrchi[ iindex ] ;
      crclo:= tablecrclow[ iindex ]     ;
      j:=j+1;
   end ;    // for


result:= (crchi shl 8 or crclo) ;

end;
FUNCTION crc16(var crcstart1:Cardinal;crcfunt:Cardinal; bytearray1:bytearray; var bytelength:integer ):word     ;
var
  I : Integer ;
  iindex,j:integer;
  crchi,crclo:integer;
begin
  
end;

procedure senddata;

 begin
  viewstring:='';
   form1.Comm1.WriteCommData(@sbuf,8)   ;
   sleep( 30 ); ;



 end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 
 richedit1.Clear;
 timer1.Enabled:=false;
 Timer2.Enabled:=false;
end;

procedure TForm1.Button1Click(Sender: TObject);
 var
 i,j:integer;
 str:string;
begin
str:='发送'+'    '+inttostr(k)+char( $0d)+char($0a);
viewstring:='' ;
form1.Comm1.WriteCommData(PChar(arrayfun),8)  ;
 sleep( 30 ); ;
//senddata;
for i:=0 to 7 do
viewstring:=viewstring+inttohex(arrayfun[i],2)+'';

 viewstring:=str+viewstring ;

 richedit1.SelStart;
  richedit1.SelAttributes.Color:=clblue;
  richedit1.Lines.Add(viewstring)  ;
 k:=k+1;

end;

procedure TForm1.Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
  BufferLength: Word);
var
 str:string;
 i:integer;

begin

viewstring:='' ;

move(buffer^,(pchar(@rbuf))^,bufferlength);

for i:=1 to bufferlength do
viewstring:=viewstring+inttohex(rbuf[i],2)+'';

  length1:=BufferLength +length1;
  str:='接收'+'    '+inttostr(j)+'    '+inttostr( length1 )+char( $0d)+char($0a);
  viewstring:=str+viewstring ;
  richedit1.SelStart;
  richedit1.SelAttributes.Color:=clred;
  richedit1.Lines.Add(viewstring)  ;
  if(tablecrc16(crcstart ,crcfunt, rbuf,BufferLength ) =0) then
  begin
   RichEdit1.Lines.add( 'CRC正确' ) ;
   StatusBar1.panels[ 7].text:='CRC正确' ;
   end else
   begin
   RichEdit1.Lines.add( 'CRC错误' );
   StatusBar1.panels[ 7].text:='CRC错误' ;
   end  ;
  richedit1.Lines.Add(#13) ;

 j:=j+1;

  
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
richedit1.Clear;
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
j:=0;
k:=0;
length1:=0;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 button1.Click;
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
 timer1.Enabled:=false;

end;

procedure TForm1.Button7Click(Sender: TObject);

begin
  timer1.Enabled:=false;
  timer1.Interval:=strtoint( Edit1.Text ) ;
  timer1.Enabled:=true;
end;

procedure TForm1.Button8Click(Sender: TObject);
begin
timer1.Enabled:=false;
end;

procedure TForm1.Button9Click(Sender: TObject);
  var
  i:integer  ;
   s:string;
begin
i:=6;
if IsHexStr(edit6.Text)   then
 begin
    StrToIntAsHex(Cardinal(i),edit6.Text  ) ;
    Label1.Caption:=inttostr( i ) ;
 end ;
  StrToIntAsHex(crcstart ,edit8.Text ) ;
  StrToIntAsHex( crcfunt,edit7.Text ) ;
 IntToStrAsHex(s ,tablecrc16(crcstart,crcfunt,bytearray(@SBUF),i ) ) ;
 edit7.Text:=  s;
end;


procedure TForm1.Edit2Exit(Sender: TObject);
begin
 if not IsHexStr(edit2.Text)   then
 messagebox( handle, '十六进制字节非法。示范：F0。', '提示', mb_ok) ;

end;

procedure TForm1.Edit3Exit(Sender: TObject);
begin
if not IsHexStr(edit3.Text)   then
 messagebox( handle, '十六进制字节非法。示范：F0。', '提示', mb_ok) ;

end;

procedure TForm1.Edit4Exit(Sender: TObject);
begin
if not IsHexStr(edit4.Text)   then
 messagebox( handle, '十六进制字节非法。示范：F0FE。', '提示', mb_ok) ;

end;

procedure TForm1.Edit5Exit(Sender: TObject);
begin
if not IsHexStr(edit5.Text)   then
 messagebox( handle, '十六进制字节非法。示范：F0FE。', '提示', mb_ok) ;

end;

procedure TForm1.Button5Click(Sender: TObject);
var
 I : Integer ;
 j:word;
 d:byte;
 strs,str2:string;
begin
setlength( arrayfun,8 ) ;
 if IsHexStr(edit2.Text)   then
 begin
    StrToIntAsHex(Cardinal(i),edit2.Text  ) ;
    d:=lo( i ) ;
 end ;
 arrayfun[ 0 ]:=d ;
 if IsHexStr(edit3.Text)   then
 begin
    StrToIntAsHex(Cardinal(i),edit3.Text  ) ;
    d:=lo( i ) ;
 end ;
 arrayfun[ 1 ]:=d ;
 if IsHexStr(edit4.Text)   then
 begin
    StrToIntAsHex(Cardinal(i),edit4.Text  ) ;
 end ;
 arrayfun[ 2 ]:=hi(i) ;
 arrayfun[ 3 ]:=lo(i) ;
 if IsHexStr(edit5.Text)   then
 begin
    StrToIntAsHex(Cardinal(i),edit5.Text  ) ;
 end ;
 arrayfun[ 4 ]:=hi(i) ;
 arrayfun[ 5 ]:=lo(i) ;
 if IsHexStr(edit7.Text)   then
    StrToIntAsHex(crcstart ,edit8.Text ) ;
 if IsHexStr(edit8.Text)   then
  StrToIntAsHex( crcfunt,edit7.Text ) ;
  i:=6 ;
  j:= tablecrc16(crcstart ,crcfunt, arrayfun,i ) ;
  IntToStrAsHex(strs,j  ) ;
     edit6.Text:=strs  ;
  arrayfun[ 6 ]:=hi(j);
  arrayfun[ 7 ]:=lo(j) ;
    str2:= '';
    strs:= '';
  for I := 0 to 7
  do    // Iterate
    begin
     IntToStrAsHex(strs,arrayfun[ i]  )   ;
      str2:=str2+ strs+'   ';
    end ;    // for
      edit9.Text:=str2;

       ;
end;

procedure TForm1.Edit10Change(Sender: TObject);
begin
 timer2.Enabled:=false;
end;

procedure TForm1.Button11Click(Sender: TObject);
begin
  timer2.Enabled:=false;
  timer2.Interval:=strtoint( Edit10.Text ) ;
  timer2.Enabled:=true;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
RichEdit1.Lines.SaveToFile('c:\wwxxccss.rtf');
end;

procedure TForm1.Button13Click(Sender: TObject);
begin

 timer2.Enabled:=false;
end;

procedure TForm1.Button12Click(Sender: TObject);
begin
winexec('C:\Program Files\Windows NT\Accessories\wordpad.exe c:\wwxxccss.rtf',sw_show);
end;

procedure TForm1.N1Click(Sender: TObject);
begin
//form2.create( self );
form2.ShowModal;

end;

procedure TForm1.N2Click(Sender: TObject);
begin
try
  form1.Comm1.StartComm ;
  StatusBar1.panels[1].Text:='打开' ;
except
 ShowMessage('打开端口错误,可能已被打开');
 StatusBar1.panels[1].Text:='关闭' ;
end;
end;

procedure TForm1.N3Click(Sender: TObject);
begin
try
 comm1.StopComm;
 StatusBar1.panels[1].Text:='关闭' ;
except
 ShowMessage('关闭端口错误');
 StatusBar1.panels[1].Text:='error' ;
end;
end;

procedure TForm1.FindDialog1Find(Sender: TObject);
var
  FoundAt: LongInt;
  StartPos, ToEnd: Integer;
begin
  with richedit1 do
  begin
    if SelLength <> 0 then
      StartPos := SelStart + SelLength
    else
      StartPos := 0;
   ToEnd := Length(Text) - StartPos ;
   FoundAt := FindText(FindDialog1.FindText, StartPos, ToEnd, [stMatchCase]);
    if FoundAt <> -1 then
    begin
      SetFocus;
      SelStart := FoundAt;
      SelLength := Length(FindDialog1.FindText);
    end else
    begin
      showmessage('没有查到相应数据。');
      SelStart := 0;
    end;
  end;
end;


procedure TForm1.find1Click(Sender: TObject);
begin
finddialog1.Execute;
end;

procedure TForm1.copyClick(Sender: TObject);
begin
RichEdit1.CopyToClipboard;
end;

procedure TForm1.paste1Click(Sender: TObject);
begin
RichEdit1.PasteFromClipboard;
end;

procedure TForm1.selectall1Click(Sender: TObject);
begin
RichEdit1.SelectAll;
end;

end.