rs485.dpr

此系统完成了485抄表

library rs485;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  SysUtils,
  Classes,
  Tcomm1,
  StrUtils,Dialogs;
var
 comm1:Tcomm;
{$R *.res}
function repl(str1: char; long1: integer): string;//补零函数
var j: integer;
var tt: string;
begin
  j := 1;
  tt := '';
  while j <= long1 do
  begin
    tt := tt + str1;
    j := j + 1;
  end;
  repl := tt;
end;
function d_hex(dec: string): string; //10进制转换16进制
var mod1, bb, sixt, cc, dh1, c2: integer;
var c1, modi1, ccc, dh: string;
begin
  bb := strtoint(dec);
  sixt := 16;
  cc := (bb);
  c1 := '';
  while cc >= sixt do
  begin
    mod1 := cc mod sixt;
    if mod1 >= 10 then
    begin
      case mod1 of
        10: modi1 := 'A';
        11: modi1 := 'B';
        12: modi1 := 'C';
        13: modi1 := 'D';
        14: modi1 := 'E';
        15: modi1 := 'F';
      end;
    end
    else
      modi1 := trim(inttostr(mod1));
    c1 := modi1 + c1;
    cc := cc div sixt;
  end;
  if cc >= 10 then
  begin
    case cc of
      10: ccc := 'A';
      11: ccc := 'B';
      12: ccc := 'C';
      13: ccc := 'D';
      14: ccc := 'E';
      15: ccc := 'F';
    end;
  end
  else
    ccc := inttostr(cc);
  dh := ccc + c1;
  dh1 := length(dh);
  if dh1 <= 4 then
  begin
    c2 := 4 - dh1;
    dh := repl('0', c2) + dh;
  end;
  d_hex := dh;
end;
function h_dec(hex: string): string;//16进制转换10进制
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;
    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 <= 4 then
  begin
    wd1 := 4 - wd;
    dc := repl('0', wd1) + dc;
  end;
  h_dec := dc
end;
function hex_str(str:string):string;//十六进制数转字符
var
  i:integer;
  f_str,v_str:string;
begin
  for i :=1  to (length(str) div 2)  do
  begin
    v_str:=copy(str,2*i-1,2);
    v_str:=h_dec(v_str);
    f_str:=f_str+char(strtoint(v_str));
  end;
  result:=f_str;
end;

function send_jy(str:string):string;///加33、算校验、加16函数 ra485和东软载波
var
  i,jy_data,qd_i:integer;
  f_str,v_str,jy_str:string;
begin
  jy_data:=0;
  qd_i:=0;
  for i :=1  to (length(str) div 2)  do
  begin
    v_str:=copy(str,2*i-1,2);
    if (i<=3) and (strtoint(h_dec(v_str))>=254) then
    begin
      f_str:=f_str+v_str;
      inc(qd_i);
      continue;
    end;
    if i<=10+qd_i then
    begin
      f_str:=f_str+v_str;
      jy_data:=jy_data+strtoint(h_dec(v_str));
    end
    else
    begin
      v_str:=rightstr(inttohex(strtoint(h_dec(v_str))+51,2),2);
      f_str:=f_str+v_str;
      jy_data:=jy_data+strtoint(h_dec(v_str));
    end;
  end;
  jy_str:=rightstr(inttohex(jy_data,2),2);
  f_str:=f_str+jy_str+'16';
  result:=f_str;
end;

function xc_send_jy(str:string):string;
var
  i,jy_data,qd_i:integer;
  f_str,v_str,jy_str:string;
begin
  jy_data:=0;
  qd_i:=0;
  for i :=1  to (length(str) div 2)  do
  begin
    v_str:=copy(str,2*i-1,2);
    if i<=12 then
    begin
      f_str:=f_str+v_str;
    end
    else
    begin
      f_str:=f_str+v_str;
      jy_data:=jy_data+strtoint(h_dec(v_str));
    end;
  end;
  jy_str:=inttohex(jy_data,4);
  f_str:=f_str+copy(jy_str,3,2)+copy(jy_str,1,2);
  result:=f_str;
end;

function revc_jy(str:string):string;////从串口收到数据后算效验函数
var
  i,jy_data,qd_i:integer;
  f_str,v_str,jy_str:string;
begin
  jy_data:=0;
  for i :=1  to ((length(str) div 2)-2)  do
  begin
    v_str:=copy(str,2*i-1,2);
    jy_data:=jy_data+strtoint(h_dec(v_str));
  end;
  jy_str:=rightstr(inttohex(jy_data,2),2);
  result:=jy_str;
end;
function data_del_33(str:string):string;/////数据区键33函数
var
  i,jy_data,qd_i:integer;
  f_str,v_str,jy_str:string;
begin
  jy_data:=0;
  for i :=1  to (length(str) div 2)  do
  begin
    v_str:=copy(str,2*i-1,2);
    v_str:=rightstr(inttohex(strtoint(h_dec(v_str))-51,2),2);
    f_str:=f_str+v_str;
  end;
  result:=f_str;
end;
//function OpenCOM(commport,baudrate,parity:string):integer;stdcall;
function OpenCOM(commport:Tcomportnumber;baudrate:Tbaudrate;parity:Tparity):integer;stdcall;
begin
  try
    comm1:=Tcomm.Create(nil);
    comm1.CommPort:=commport;
    comm1.BaudRate:=baudrate;
    comm1.Parity:=parity;
    comm1.DataBits:=db8;
    comm1.StopBits:=sb1;
    comm1.PortOpen:=true;
    comm1.DTREnabled:=true;
    comm1.RTSEnabled:=true;
    comm1.DataCount:=0;
    comm1.RThreshold:=1;
    result:=0;
  except
    result:=-1;
  end;
end;
function NgOUT(
  sendstr:string;h_delay:integer;revc_delay:integer):integer;stdcall;//宁光
var
  send_str,str,fh_str,ss,kzm,fh_len,err_data,sj_len,js_jy,fh_jy,fh_16,fh_data:string;
  i,data_len:integer;
  p_lean:boolean;
  fp:textfile;
begin
   send_str:=trim(sendstr);
   str:=send_jy(send_str);
   str:=hex_str(str);
   comm1.RTSEnabled:=false;
   for i :=1  to length(str) do
   begin
     sleep(10);
     comm1.OutputString(str[i]);
   end;
   sleep(50);//此处延时必须要设置
   comm1.RTSEnabled:=true;
   for i :=0  to 50 do
   begin
     sleep(h_delay);//20
     comm1.InputLen:=1;
     fh_str:=comm1.Input;
     if fh_str='68' then
       break
     else if i=50 then
     begin
       result:=-3; ////没有收到包头68
       exit;
     end;
   end;
   ss:=fh_str;
   sleep(revc_delay);
   comm1.InputLen:=9;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   kzm:=copy(fh_str,15,2);
   kzm:=copy(kzm,1,1);
   if kzm='C' then
   begin
     result:= -4;////////其它错误
     exit;
   end;
   fh_len:=copy(fh_str,17,2);
   sj_len:=h_dec(fh_len);
   data_len:=strtoint(sj_len);
   sleep(revc_delay);//400
   comm1.InputLen:=data_len+2;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   js_jy:=revc_jy(ss);
   fh_jy:=copy(rightstr(ss,4),1,2);
   fh_16:=copy(rightstr(ss,4),3,2);
   if fh_jy<>js_jy then
   begin
     result:= -2;////////效验错误
     exit;
   end;
   if fh_16<>'16' then
   begin
     result:= -1; ///////没有收到结尾符16
     exit;
   end;
   fh_data:=copy(ss,21,length(ss)-24);
   fh_data:=data_del_33(fh_data);
   if fileexists('revc.dat') then
        deletefile('revc.dat');
   assignfile(fp,'revc.dat');
   rewrite(fp);
   writeln(fp,fh_data);
   closefile(fp);
   result:=0;
end;

function EasOUT(sendstr:string;mac_flag:integer;h_delay:integer;revc_delay:integer):integer;stdcall;//东软
var
  send_str,str,fh_str,ss,kzm,fh_len,err_data,sj_len,js_jy,fh_jy,fh_16,fh_data,mac_str:string;
  i,data_len:integer;
  p_lean:boolean;
  fp:textfile;
begin
   send_str:=trim(sendstr);
   str:=send_jy(send_str);
   str:=hex_str(str);
   comm1.RTSEnabled:=false;
   for i :=1  to length(str) do
   begin
     sleep(5);
     comm1.OutputString(str[i]);
   end;
   sleep(50);
   comm1.RTSEnabled:=true;
   for i :=0  to 100 do ////循环值在100
   begin
     sleep(h_delay); ////经过调试延时值在30－35稳定
     comm1.InputLen:=1;
     fh_str:=comm1.Input;
     if fh_str='68' then
       break
     else if i=100 then
     begin
       result:=-3; ////没有收到包头68
       exit;
     end;
   end;
   ss:=fh_str;
   sleep(revc_delay);
   comm1.InputLen:=9;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   mac_str:=copy(fh_str,1,12);
   kzm:=copy(fh_str,15,2);
   kzm:=copy(kzm,1,1);
   if kzm='C' then
   begin
     result:= -4;////////其它错误
     exit;
   end;
   fh_len:=copy(fh_str,17,2);
   sj_len:=h_dec(fh_len);
   data_len:=strtoint(sj_len);
   sleep(revc_delay);
   comm1.InputLen:=data_len+2;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   js_jy:=revc_jy(ss);
   fh_jy:=copy(rightstr(ss,4),1,2);
   fh_16:=copy(rightstr(ss,4),3,2);
   if fh_jy<>js_jy then
   begin
     result:= -2;////////效验错误
     exit;
   end;
   if fh_16<>'16' then
   begin
     result:= -1; ///////没有收到结尾符16
     exit;
   end;
   if mac_flag=0 then
   begin
     fh_data:=copy(ss,21,length(ss)-24);
     fh_data:=data_del_33(fh_data);
   end
   else
     fh_data:=mac_str;
   if fileexists('revc.dat') then
        deletefile('revc.dat');
   assignfile(fp,'revc.dat');
   rewrite(fp);
   writeln(fp,fh_data);
   closefile(fp);
   result:=0;
end;

function XcOUT(
  sendstr:string;h_delay:integer;revc_delay:integer):integer;stdcall;//小程
var
  send_str,str,pd_c_d,fh_str,ss,kzm,fh_len,err_data,sj_len,js_jy,fh_jy,fh_16,fh_data,ss1,send_ml,revc_ml:string;
  i,data_len:integer;
  p_lean:boolean;
  fp:textfile;
begin
   send_str:=trim(sendstr);
   send_ml:=copy(sendstr,35,4);
   showmessage('send_ml='+send_ml);
   str:=xc_send_jy(send_str);
   str:=hex_str(str);
   comm1.RTSEnabled:=false;
   for i :=1  to length(str) do
   begin
     sleep(20);
     comm1.OutputString(str[i]);
   end;
   comm1.RTSEnabled:=true;
   for i :=0  to 50 do
   begin
     sleep(h_delay);
     comm1.InputLen:=2;
     fh_str:=comm1.Input;
     if fh_str='4441' then
       break
     else if i=50 then
     begin
       result:=-3; ////没有收到包头68
       exit;
     end;
   end;
   ss:=fh_str;
   sleep(revc_delay);
   comm1.InputLen:=9;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   ss1:=copy(fh_str,9,10);
   kzm:=copy(fh_str,15,2);
   kzm:=copy(kzm,1,1);
   if kzm='C' then
   begin
     result:= -4;////////效验错误
     exit;
   end;
   fh_len:=copy(fh_str,17,2);
   sj_len:=h_dec(fh_len);
   data_len:=strtoint(sj_len);
   sleep(revc_delay);
   comm1.InputLen:=data_len+2;
   fh_str:=comm1.Input;
   ss:=ss+fh_str;
   ss1:=ss1+fh_str;
   js_jy:=revc_jy(ss1);
   fh_jy:=copy(rightstr(ss,4),1,2);
   fh_16:=copy(rightstr(ss,4),3,2);
   if fh_jy<>js_jy then
   begin
     result:= -2;////////效验错误
     exit;
   end;
   fh_data:=copy(ss,23,length(ss)-26);
   revc_ml:=copy(fh_data,1,4);
   showmessage('revc_ml='+revc_ml);
   if send_ml<>revc_ml then
   begin
     result:= -5;
     exit;
   end;
   if fileexists('revc.dat') then
        deletefile('revc.dat');
   assignfile(fp,'revc.dat');
   rewrite(fp);
   writeln(fp,fh_data);
   closefile(fp);
   result:=0;
end;


function CloseCOM():integer;stdcall;
begin
   try
    comm1.PortOpen:=false;
    result:=0;
   except
    result:=-1;
   end;
  comm1.Free;
end;
exports
  OpenCOM,CloseCOM,NgOUT,EasOUT,XcOUT;
begin
end.