combas.pas

完成虚拟的多功能电能表

unit combas;

interface

uses
  Windows,Forms,MSCommLib_TLB,SysUtils,messages;

const
  Wm_Send_Data=Wm_User+16;//TzForm's Command
  Wm_Data_Refresh=Wm_User+22;//DQBForm's Command
type
  m_db =record
  jbcs:integer;
  gcover:boolean;
  select:boolean;
  wl_select:boolean;
  thjg:boolean;
  zcbh:string[30];
  ccbh:string[20];
  sjdw:string[20];
  ccrq:string[10];
  zzbz:string[16];
  zzcm:string[40];
  xh:string[16];
  cs:string[6];
  cs2:string[6];
  jb:integer;
  jb2:integer;
  jxfs:integer;
  jrfs:integer;
  eddy:integer;
  eddl:Double;
  dlbl:integer;
  csdw:integer;
  blx:Integer;
  zns:boolean;
 // xds:boolean;
  xbsj:boolean;
  sxb:string[40];
  jyjg:string[1];
  qian:string[1];
  qi:string[1];
  qddl:integer;
  jbrq:string[10];
  jbry:string[8];
  zgry:string[8];
  hyry:string[8];
  jbwd:string[2];
  jbsd:string[2];
  zi:string[10];
  yxrq:string[10];
  hao:string[10];
  tqz:string[6];
  tqf:string[6];
  tqg:string[6];
  tqp:string[6];
  thz:string[6];
  thf:string[6];
  thg:string[6];
  thp:string[6];
  h2410:string[6];
  h2405l:string[6];
  s10:string[6];
  s05l:string[6];
  zgjc:string[1];
  nysy:string[10];
  tzsy:string[1];
  zzsy:string[1];
  bz:string[30];
  zzbh:string[10];
  bwsjx:string[3];
  bwsyj:string[3];
  s08c:string[6];
  zdsycount:integer;
  sdsycount:integer;
//  jbjg:array [0..127] of Twc;
//  sdjg:array [0..127] of Twc;
end;

 Function psdAdd(tmpsd:String;tmpctl:Boolean):String;
 Function cmd_fs(dd:TMSComm;cmd:String):Boolean;
 Function line_485(dd:TMSComm;cmd:String;bw:Integer):Boolean;
 Function sj_fs(dd:TMSComm;str_fs:String):Boolean;
 Function sj_fsr(dd:TMSComm;str_fs:String):Boolean;
 Function sj_js(dd:TMSComm;str_len:integer):String;
 Function bzb_js(dd:TMSComm;str_len:integer):String;

 function ExecuteFile(const FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;

 Function data_RECALL(tmp0:String;tmp1,tmp2:Byte):String;
 Function data_CALL(tmp0:String;tmp1:integer;tmp2:boolean):String;
 Function data_chang(tmp0:String;tmpctl:Boolean):String;
 function hexadd(hexstr:String):String;
 function hexdel(hexstr:string):string;
 Function strhex(tmpstr:String;tmp1,tmp2:Byte):String;
 Function StrToHex(tmpstr:String):String;
 
 Function sjhz(sj,dj:Double):String;
 Function strrev(mystr:string):string;
 Function valsndform(sz_val:Double;sz_frm:string):String;
 Function nowtime:Double;
 Function mid(mystr:string;strstart,str_len:integer):string;
 Function leftstr(mystr:string;str_len:Integer):string;
 Function rightstr(mystr:string;str_len:Integer):string;
 Function instr(surstr,destr:string):Integer;
 Function timestr(tmpval:integer):String;
 Function time_str(tmpval:integer):String;
 Function strtime(tmpval:String):Integer;
 //Function comyes:Boolean;
 Function comyes(dd:TMSComm):Boolean;
 Function StrToFloatDef(tmp:String;tmpval:Double):Double;
 function predate(ndate:TDateTime;fyear:Integer):String; //计算前一天
 Function formatdj(tmpdj:String):String;
 Function getwc(wcno:Integer;wcbz:String;var wczz:String):String;
 Function hyval(tmpstr:String):Double;
 Function SetPCSystemTime(tDati: TDateTime): Boolean;
 Function formatstr(tmpformat,tmp:String):String;
 function data_reset(tmp0:string):string;

 Procedure spkbeep(beepnum:Integer);
 Procedure delay(dels:Double);
 Procedure Doevents;




procedure PackDbfTable(Tablename:String);

implementation
uses ShellAPI,BDE;

procedure PackDbfTable(Tablename:String);
var
 hDb:hDBIDb;
 hCursor:hDBICur;
 DBResult:DBIResult;
 szTableName:Pchar;
 PathLength:integer;
begin
 PathLength:=120;
 Getmem(szTableName,PathLength);
 strpcopy(szTableName,TableName);
 try
  DBResult:=(DBIInit(nil));
  if DBResult<>DBIERR_NONE then begin
   DBIExit;
   exit;
  end;
  DBResult:=(DBIOpenDataBase(nil,nil,DBIReadWrite,DBIOpenShared,
    nil,0,nil,nil,hDB));
  if DBResult<>DBIERR_NONE then begin
   DBIExit;
   exit;
  end;
  DBResult:=DBIOpenTable(hdb,sztablename,nil,nil,nil,0,DBIReadWrite,DBIOpenExcl,XLTNONE,False,nil,hCursor);
  if DBResult<>DBIERR_NONE then begin
   DBIExit;
   exit;
  end;
  try
  DBResult:=DBIPackTable(hDB,hcursor,szTableName,nil,True);
  if DBResult<>DBIERR_NONE then begin
   DBIExit;
   exit;
  end;
  finally
   DBICloseCursor(hcursor);
   DBICloseDataBase(hdb);
   DBIExit;
  end;
 finally
   FreeMem(szTableName,PathLength);
 end;
end;

Function psdAdd(tmpsd:String;tmpctl:Boolean):String;
var
 tmplen,i:Integer;
 tmpstr:String;

begin
 tmpstr:='';
 tmplen:=length(tmpsd);
 for i:=1 to tmplen do
  if tmpctl then
   tmpstr:=tmpstr+Chr(ord(tmpsd[i])+$10+i)
  else
   tmpstr:=tmpstr+Chr(ord(tmpsd[i])-$10-i);
 Result:=tmpstr;
end;

Function data_RECALL(tmp0:String;tmp1,tmp2:Byte):String;
var
 tmp,tmpstr:String;
begin
 tmp:=Mid(tmp0,tmp1,tmp2);
 tmpstr:=IntToHex(StrToInt('$'+tmp)-$33,2);
 if length(tmpstr)>2 then
  Result:=RightStr(tmpstr,2)
 else
  Result:=tmpstr;
end;


function data_reset(tmp0:string):string;
var
  i:integer;
  tmpstr:string;
  tmp1:integer;
begin
  tmpstr:='';
  tmp1:=length(tmp0);
  for i:=0 to tmp1-1 do
    tmpstr:=mid(tmp0,1+i*2,2)+tmpstr;
  result:=tmpstr;
end;


Function data_CALL(tmp0:String;tmp1:integer;tmp2:boolean):String;
var
 tmp,tmpstr:String;
 i,num:integer;
 tmpval:double;
begin
 if tmp2 then
 begin
   num:=length(tmp0)-instr(tmp0,'.');
   tmpval:=1;
   for i:=1 to num do
     tmpval:=tmpval*10;
   tmp:='';
   for i:=1 to tmp1 do
     tmp:=tmp+'0';
   tmp0:=formatfloat(tmp,strtofloat(tmp0)*tmpval);
 end else
 begin
   tmp:='';
   for i:=1 to tmp1-length(tmp0) do
     tmp:=tmp+'0';
   tmp0:=tmp+tmp0;
 end;
 tmp1:=round(tmp1/2)-1;
 for i:=0 to tmp1 do
 begin
   tmp:=Mid(tmp0,i*2+1,2);
   tmpstr:=IntToHex(StrToInt('$'+tmp)+$33,2)+tmpstr;
 end;
 Result:=tmpstr;
end;

Function data_chang(tmp0:String;tmpctl:Boolean):String;
var
 tmp,tmpstr:String;
 i,tmplen:integer;
begin
 tmplen:=length(tmp0) div 2;
 tmp:='';
 for i:=tmplen downto 1 do
  begin
   tmpstr:=Mid(tmp0,(i-1)*2+1,2);
   if tmpctl then
    tmpstr:=IntToHex(StrToInt('$'+tmpstr)+$33,2);
   if length(tmpstr)>2 then
    tmpstr:=RightStr(tmpstr,2);
   tmp:=tmp+tmpstr;
  end;
 Result:=tmp;
end;


function hexdel(hexstr:string):string;
var
  i,tmplen:integer;
  tmpstr:string;
begin
  tmplen:=length(hexstr);
  if (tmplen mod 2)<>0 then
  begin
    result:='BAD_STR';
    exit;
  end;
  tmplen:=tmplen div 2;
  tmpstr:='';
  for i:=0 to tmplen-1 do
    tmpstr:=tmpstr+IntToHex(StrToInt('$'+mid(hexstr,i*2+1,2))-$33,2);
  result:=tmpstr;
end;

{function formatstr(tmp1,tmpstr:string):string;
begin
  try
    result:=formatfloat(tmp1,strtofloat(tmpstr));
  except
    result:='0';
  end;
end;}
function hexadd(hexstr:String):String;
var
 i,tmplen:integer;
 tmpstr:String;
 tmpval:Integer;
begin
 tmplen:=length(hexstr);
 if (tmplen mod 2)<>0 then
 begin
  Result:='BAD_STR';
  exit;
 end;
 tmplen:=tmplen div 2;
 tmpval:=0;
 for i:=1 to tmplen do
  begin
   tmpstr:=mid(hexstr,2*i-1,2);
   tmpval:=StrToInt('$'+tmpstr)+tmpval;
  end;
 tmpstr:=IntToHex(tmpval,2);
 if length(tmpstr)>2 then
  tmpstr:=rightstr(tmpstr,2);
 Result:=tmpstr;
end;

Function strhex(tmpstr:String;tmp1,tmp2:Byte):String;
var
 tmp:String;
begin
 tmp:=Mid(tmpstr,tmp1,tmp2);
 if tmp='' then
 begin
  Result:='';
  exit;
 end;
 tmp:=FormatFloat('00',StrToInt('$'+tmp));
 Result:=tmp;
end;

function ExecuteFile(const FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;
var
  zFileName, zParams, zDir:Array [0..100] of char;
begin
  Result := ShellExecute(Application.MainForm.Handle, nil,
    StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
    StrPCopy(zDir, DefaultDir), ShowCmd);
end;

Function cmd_fs(dd:TMSComm;cmd:String):Boolean;
var
 tmpcomm:Boolean;
begin
 tmpcomm := comyes(dd);
 If Not tmpcomm Then
 begin
  result:=False;
  exit;
 end;
 dd.Output:=cmd;
 result:=True;
end;

Function line_485(dd:TMSComm;cmd:String;bw:Integer):Boolean;
begin
{ if not GL485line then begin
  Result:=True;
  exit;
 end;
 //485继电器
 if cmd_fs(dd,'l'+Chr(bw)+'A'+cmd+'00000E') then begin
  delay(0.5);
  Result:=True
 end else
  Result:=False;}
end;

Function sj_fsr(dd:TMSComm;str_fs:String):Boolean;
var
 i:Integer;
 tmpcomm:Boolean;
 MyVariant: Variant;

 begin
 MyVariant :=VarArrayCreate ([0,Trunc(length(str_fs)/2)-1], varByte);
 if InStr(str_fs,'45')=0 then
  begin
   result:=False;
   exit;
  end;
   i:=0;
   while True do
   begin
   MyVariant[i]:=StrToInt('$'+Mid(str_fs,i*2+1,2));
   if MyVariant[i]=$45 then break;
   Inc(i);
   end;
   tmpcomm := comyes(dd);
   If Not tmpcomm Then
   begin
    result:=False;
    exit;
   end;
   dd.Output:=MyVariant;
   result:=True;
end;

Function sj_fs(dd:TMSComm;str_fs:String):Boolean;
var
 i:Integer;
 tmpcomm:Boolean;
 MyVariant: Variant;
 len:integer;

 begin
{if GLXLBTX then begin
 len:=length(str_fs) div 2-2;
 MyVariant :=VarArrayCreate ([0,(length(str_fs) div 2-1)], varByte);
 MyVariant[0]:=StrToInt('$'+'58');
 MyVariant[1]:=StrToInt('$'+IntToHex(len,2));
 for i:=1 to len do
  MyVariant[i+1]:=StrToInt('$'+Mid(str_fs,i*2+1,2));
 tmpcomm := comyes(dd);
   If Not tmpcomm Then
   begin
    result:=False;
    exit;
   end;
  dd.Output:=MyVariant;
  result:=True;
end
else begin}
 MyVariant :=VarArrayCreate ([0,Trunc(length(str_fs)/2)-1], varByte);
// if InStr(str_fs,'45')=0 then
//  begin
//   result:=False;
//   exit;
//  end;
{   i:=0;
   while True do
   begin
   MyVariant[i]:=StrToInt('$'+Mid(str_fs,i*2+1,2));
//   if MyVariant[i]=$45 then break;
   Inc(i);
   end;}
   for i:=0 to Trunc(length(str_fs)/2)-1 do
     MyVariant[i]:=StrToInt('$'+Mid(str_fs,i*2+1,2));
   tmpcomm := comyes(dd);
   If Not tmpcomm Then
   begin
    result:=False;
    exit;
   end;
   dd.Output:=MyVariant;
   result:=True;
//end;
end;

Function sj_js(dd:TMSComm;str_len:integer):String;
var
 MyVariant: Variant;
 tmpbyte:integer;
 i:integer;
 tu:Double;
 tmpstr:String;

begin
 MyVariant := VarArrayCreate([0,str_len-1], varByte);
 dd.InputMode:=1;
 dd.InputLen:=0;
 dd.RThreshold:=0;
 dd.InBufferCount:=0;
 tu := nowTime;
 repeat
   if nowTime-tu>5 then
     begin
      spkbeep(50);
      //Application.MessageBox('接收中断！','警告',mb_OK+mb_ICONSTOP);
      dd.InputMode:=0;
      dd.InputLen:=1;
      dd.RThreshold:=1;
      dd.InBufferCount:=0;
      Result:='RECV_BAD';
      exit;
     end;
   DoEvents;
 until dd.InBufferCount>=str_len;
 MyVariant:=dd.Input;
 dd.InputMode:=0;
 dd.InputLen:=1;
 dd.RThreshold:=1;
 dd.InBufferCount:=0;
 tmpstr:='';
 for i:=0 to str_len-1 do
  begin
   tmpbyte:=MyVariant[i];
   tmpstr:=tmpstr+IntToHex(tmpbyte,2);
//   if tmpbyte=13 then break;
  end;
{ if (Instr(tmpstr,'58')=0) or (Instr(tmpstr,'5845')=1)  or (Instr(tmpstr,'580045')=1) then
 begin
  spkbeep(50);
  Application.MessageBox('表无应答！','警告',mb_OK+mb_ICONSTOP);
  Result:='RECV_BAD';