unit1.pas

此程序完全按照645协议编写的485抄表程序 波特率1200

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Mask;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    Edit2: TEdit;
    Edit3: TEdit;
    Button4: TButton;
    Edit6: TEdit;
    Label1: TLabel;
    Label3: TLabel;
    Label2: TLabel;
    Label4: TLabel;
    Edit5: TEdit;
    Label5: TLabel;
    Panel1: TPanel;
    Label6: TLabel;
    ComboBox1: TComboBox;
    Button2: TButton;
    ComboBox2: TComboBox;
    Label7: TLabel;
    Button18: TButton;
    MaskEdit1: TMaskEdit;
    MaskEdit2: TMaskEdit;
    Label8: TLabel;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Edit1Exit(Sender: TObject);
    procedure Edit6Exit(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure Button11Click(Sender: TObject);
    procedure Button12Click(Sender: TObject);
    procedure Button13Click(Sender: TObject);
    procedure Button14Click(Sender: TObject);
    procedure Button18Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }

  end;

var
  Form1: TForm1;
  hcomm:thandle;
  valu : string;
  aa,bb,ccc:string;
  alldata:string;
  packdata:string;
implementation
function  Open300(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close300():integer;stdcall;external 'InfraredCom.dll';
function  ComOut300(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';

function  Open600(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close600():integer;stdcall;external 'InfraredCom.dll';
function  ComOut600(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';

function  Open1200(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close1200():integer;stdcall;external 'InfraredCom.dll';
function  ComOut1200(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';

function  Open2400(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close2400():integer;stdcall;external 'InfraredCom.dll';
function  ComOut2400(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';

function  Open4800(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close4800():integer;stdcall;external 'InfraredCom.dll';
function  ComOut4800(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';

function  Open9600(aa:string):integer;stdcall;external 'InfraredCom.dll';
function  Close9600():integer;stdcall;external 'InfraredCom.dll';
function  ComOut9600(aa:string;bb:integer;cc:integer;dd:integer):longint;stdcall;external 'InfraredCom.dll';


{$R *.dfm}

function hex_str1(send: string): string;  //hex to char
var
  len, a1, i, n, m: Integer;
  aa: string;
begin
  aa := '';
  len := Length(send);
  len := len div 2;
  for i := 1 to len do
  begin
    n := ord(send[2 * i - 1]);
    if ((n >= 48) and (n < 58)) then
      n := n mod 16
    else if (((n > 64) and (n < 71)) or ((n > 96) and (n < 103))) then
    begin
      n := n mod 16;
      n := n + 9;
    end
    else
    begin
      exit;
    end;
    m := ord(send[2 * i]);
    if ((m >= 48) and (m < 58)) then
      m := m mod 16
    else if (((m > 64) and (m < 71)) or ((m > 96) and (m < 103))) then
    begin
      m := m mod 16;
      m := m + 9;
    end
    else
    begin
      exit;
    end;
    a1 := 16 * n + m;
    aa := aa + chr(a1);
  end;
  result := aa;
end;
function h_dec(hex: string): string;stdcall;
var i, c, l, x, bb, a1, c2, wd, wd1: integer;
var ai, dc: string;
begin
  i := 0;
  c := 0;
  x := 1;
  wd := 1;
  l := length(hex);
  while i < l do
  begin
    case i of
      0: x := 1;
      1: x := 16;
      2: x := 16 * 16;
      3: x := 16 * 16 * 16;
      4: x := 16 * 16 * 16 * 16;
      5: x := 16 * 16 * 16 * 16 * 16;
      6: x := 16 * 16 * 16 * 16 * 16 * 16;
      7: x := 16 * 16 * 16 * 16 * 16 * 16*16;
    end;
    bb := l - i;
    ai := copy(hex, bb, 1);
    case ai[1] of
      'A': a1 := 10;
      'a': a1 := 10;
      'B': a1 := 11;
      'b': a1 := 11;
      'C': a1 := 12;
      'c': a1 := 12;
      'D': a1 := 13;
      'd': a1 := 13;
      'E': a1 := 14;
      'e': a1 := 14;
      'F': a1 := 15;
      'f': a1 := 15
    else
      a1 := strtoint(ai);
    end;
    c2 := a1 * x;
    c := c2 + c;
    i := i + 1;
    dc := trim(inttostr(c));
    wd := length(dc);
  end;
  if wd <= 2 then
  begin
    wd1 := 2 - wd;
    dc := copy('00',1,wd1) + dc;
  end;
  h_dec := dc
end;
function f_dectohex(s:string):string;stdcall;
var
j,k:integer; s1,s2,m:string;
begin
k:=strtoint(s);
s1:='';
while k>=16 do
 begin
   j:=k mod 16;
   case j of
   10:  s2:='A';
   11:  s2:='B';
   12:  s2:='C';
   13:  s2:='D';
   14:  s2:='E';
   15:  s2:='F';
   else
      s2:=trim(inttostr(j));
   end;
s1:=s2+s1;
    s1:=trim(s1);
    k:=k div 16;
 end;
  case k of
    10:  m:='A';
    11:  m:='B';
    12:  m:='C';
    13:  m:='D';
    14:  m:='E';
    15:  m:='F';
    else
         m:=inttostr(k);
  end;
 s1:=m+s1;
 if length(s1)=1 then
    s1:='0'+s1;
 f_dectohex:=s1;
end;
//function str_hex(str:string):string; //char to hex
function str_hex(str:pchar;long:integer):string; //char to hex
var
t,count:integer;
s,val,sj:string;
begin
s:='';
t:=1;
alldata:='';
count:=0;
while t=1 do
begin
   val:=inttostr(ord(str[count]));
   sj:=f_dectohex(val);
   s:=s+sj;
   alldata:=alldata+sj;
   if long<10 then
   begin
     IF count>11+long THEN
     BEGIN
      str_hex:='9999' ;
      EXIT;
     END;
     if (sj='0D') and (count=10+long) then
     begin
      str_hex:=s;
      exit;
     end;
   end;
   if long>=10 then
   begin
     IF count>11+long*2 THEN
     BEGIN
      str_hex:='9999' ;
      EXIT;
     END;
     if sj='0D' then
     if (sj='0D') and (count=10+long*2) then
     begin
      str_hex:=s;
      exit;
     end;
   end;
  count:=count+1;
end;
str_hex:=s;
end;
////////////////////////////////////////////////
function str_hexaaa(str:pchar;long:integer):string; //char to hex
var
t,count:integer;
s,val,sj:string;
begin
s:='';
t:=1;
alldata:='';
count:=0;
while count<long do
begin
   val:=inttostr(ord(str[count]));
   sj:=f_dectohex(val);
   s:=s+sj;
   alldata:=alldata+sj;
   count:=count+1;
end;
str_hexaaa:=s;
end;
/////////////////////////////////////////////////
 function str_hextry(str:pchar;long:integer):string; //char to hex
var
t,count:integer;
s,val,sj:string;
begin
s:='';
t:=1;
alldata:='';
count:=0;
while count<long do
begin
   val:=inttostr(ord(str[count]));
   sj:=f_dectohex(val);
   s:=s+sj;
   alldata:=alldata+sj;
  count:=count+1;
end;
str_hextry:=s;
end;
function str_hexpack(str:pchar;long:integer):string; //char to hex
var
t,count:integer;
s,val,sj:string;
begin
s:='';
t:=1;
//alldata:='';
count:=0;
while t=1 do
begin
   val:=inttostr(ord(str[count]));
   sj:=f_dectohex(val);
   s:=s+sj;
   if length(sj)<2 then
   sj:='0'+sj;
   alldata:=alldata+sj;
   IF count>12+long*2 THEN
   BEGIN
    str_hexpack:='9999' ;
    EXIT;
   END;
   //if sj='0D' then
   //showmessage(inttostr(i));
   if (sj='0D') and (count=11+long*2) then
   begin
    //showmessage(inttostr(count)+' '+sj);
    str_hexpack:=s;
    exit;
   end;
  count:=count+1;
end;
str_hexpack:=s;
end;
function str_hexpackz(str:pchar;long:integer):string; //char to hex
var
count:integer;
s,val,sj:string;
begin
s:='';
count:=0;
while count<=long do
begin
   val:=inttostr(ord(str[count]));
   sj:=f_dectohex(val);
   if length(sj)<2 then
   sj:='0'+sj;
   s:=s+sj;
   alldata:=alldata+sj;
   count:=count+1;
end;
str_hexpackz:=s;
end;
function dec_three(str:string):string;
var
len,i,val:integer;
 s0,s1,s2,ss:string;
begin
i:=1;
len:=length(trim(str));
while i<len do
begin
s0:=h_dec(copy(str,i,2));
s1:=h_dec('33');
val:=strtoint(s0)-strtoint(s1);
s2:=f_dectohex(inttostr(val));
ss:=ss+copy(s2,length(s2)-1,2);
i:=i+2;
end;
dec_three:=ss;
end;
 function tzstrx(bb:string):string;
   var lenn,i:integer;
       aa:string;
   begin
     lenn:=length(bb);
     aa:='';
     i:=lenn;
     while i>0 do
       begin
         aa:=aa+copy(bb,i-1,2);
         lenn:=lenn-2;
         i:=lenn;
       end;
     tzstrx:=aa;
   end;
function Open(com:string;btl:string):integer;stdcall;
var
  cc:Tcommconfig;
  Temp:string;
begin
  Temp:=com;
  hcomm:=createfile(pchar(temp),generic_read or generic_write,0,nil,Open_existing,0,0);
  if (hcomm=invalid_handle_value) then
  begin
  result:=-1;
  exit;
  end;
  getcommstate(hcomm,cc.dcb);
  if btl='300' then
  cc.dcb.baudrate:=cbr_300;
  if btl='600' then
  cc.dcb.baudrate:=cbr_600;
  //if btl='900' then
  //cc.dcb.baudrate:=cbr_900;
  if btl='1200' then
  cc.dcb.baudrate:=cbr_1200;
  if btl='2400' then
  cc.dcb.baudrate:=cbr_2400;
  if btl='4800' then
  cc.dcb.baudrate:=cbr_4800;
  if btl='9600' then
  cc.dcb.baudrate:=cbr_9600;
  cc.dcb.bytesize:=8;
  cc.dcb.Flags:=3;
  cc.dcb.parity:=evenparity;//noparity;
  cc.dcb.stopbits:=onestopbit;
 //////////////////////////////
 {EscapeCommFunction(hcomm, );
 CLRDTR	Clears the DTR (data-terminal-ready) signal.
 CLRRTS	Clears the RTS (request-to-send) signal.
 SETDTR	Sends the DTR (data-terminal-ready) signal.
 SETRTS	Sends the RTS (request-to-send) signal.
 SETXOFF	Causes transmission to act as if an XOFF character has been received.
 SETXON	Causes transmission to act as if an XON character has been received.
 SETBREAK	Suspends character transmission and places the transmission line in a break state until the ClearCommBreak function is called (or EscapeCommFunction is called with the CLRBREAK extended function code). The SETBREAK extended function code is identical to the SetCommBreak function. Note that this extended function does not flush data that has not been transmitted.
 CLRBREAK	Restores character transmission and places the transmission line in a nonbreak state. The CLRBREAK extended function code is identical to the ClearCommBreak function.
 }
 //////////////////////////////
  if not setcommstate(hcomm,cc.dcb)  then
   begin
     result:=-1;
     exit;
  end
  else
  result:=0;
end;
function Close():integer;stdcall;
begin
Closehandle(hcomm);
result:=0;
end;
procedure WriteCom(str:string);stdcall;
var
  temp:string;
  IRC:longword;
begin
 // if (hcomm=0) then exit;
  temp:=str;
  writefile(hcomm,pchar(temp)^,length(temp),irc,nil);
end;
function ReadCom(var s:pchar):integer;stdcall;
var
  inbuff: array[0..1023] of Char;// string;
  nBytesRead,dwError:LongWORD ;
  cs:TCOMSTAT;
 begin
 ClearCommError(hComm,dwError,@CS);  //取得状态
 ReadFile(hComm, inbuff,cs.cbInQue,nBytesRead,nil); // 接收COM 的数据
 if cs.cbInQue >sizeof(inbuff) then  // length(inbuff)then   // 数据是否大于我们所准备的Buffer
 begin
   PurgeComm(hComm, PURGE_RXCLEAR);    // 清除COM 数据
   result:=-1;
   exit;
 end;
 s:=inbuff;
 result:=0;//trim(Copy(inbuff,1,cs.cbInQue));    //转移数据到变量中
end;
function ComOut(str:string;len:integer):integer;stdcall;
var
s0,s1,s2,s3,ss,shu,clc:string;
xyw,xys,ch,sj:string;
xy,i,k,cd,cd1,l,j:integer;
fp:textfile;
val,val1:pchar;
begin
l:=1;
i:=1;
ss:='';
xy:=0;
while i<length(str) do
begin
 s0:=h_dec(copy(str,i,2));
 xy:=xy+strtoint(s0);
 i:=i+2;
end;
 xyw:=f_dectohex(inttostr(xy));
 if length(xyw)>2 then
 xyw:=copy(xyw,2,2);
 str:=str+xyw+'16';
 aa:=str;
 ss:=hex_str1(str);
 bb:=ss;
 WriteCom(ss);
 sleep(2500);
 j:=ReadCom(val);
 Close();
 shu:=str_hexaaa(val,len);
 ccc:=shu;
 ComOut:=0
end;
function ComOutpack(str:string;len:integer):integer;stdcall;
var
s0,s1,s2,s3,ss,shu,clc:string;
xyw,xys,ch,sj,xorsj:string;
xy,i,j,k,xy1,cd,cd1,l:integer;
fp:textfile;
val,val1:pchar;
begin
l:=1;
i:=1;
j:=-1;
ss:='';
xy:=0;
xy1:=0;
xorsj:='0';
while i<length(str) do
begin
 s0:=h_dec(copy(str,i,2));
 xorsj:=inttostr(strtoint(xorsj) xor strtoint(s0));