pack_crcunit1.pas

delphi开发的抄表数据管理系统

unit Pack_CRCUnit1;

interface
Const crcd = $102100;
Const crMyCursor = 1;
Function Packfj(pked:String):boolean;
Function Pack(pked:String):boolean;
Function CRC(CRCedStr:string;SendFlag:Boolean):integer;
function extract(s:string):string;
function extractinf(s:string):string;
function extractcure(s:string):string;
var
   UserLev:string;
implementation
uses
    SysUtils,pcomm,HrUnit1,forms,Dialogs,strutils;
function GetTickCount:integer;far;external 'Kernel32.dll'
//******************************************************************************
function CRC(CRCedstr:string;Sendflag:Boolean):integer;
var
   StrLen:integer;
   Ysq,i,j:Integer;
begin
   StrLen:=length(CRCedstr);
   if StrLen = 0 then
   begin
       CRC:=0;
       Exit;
   end;
   Ysq:=ord(CRCedstr[1])*256;
   for j:=2 to StrLen do
   begin
       Ysq:=Ysq+ord(CRCedstr[j]);
       for i:=1 to 8 do
       begin
           Ysq:=Ysq * 2;
           if (Ysq and $1000000)<>0 then
              Ysq:=Ysq xor Crcd;
           Ysq:=Ysq mod $1000000;
       end;
   end;
   if SendFlag then
       for i:=1 to 16 do
       begin
           Ysq:= Ysq * 2;
           if (Ysq and $1000000)<>0 then
              Ysq:=Ysq xor crcd;
           Ysq:=Ysq mod $1000000;
       end;
   CRC:=Ysq div 256;
end;
//******************************************************************************
Function PackFJ(pked:String):boolean;     //打包字符串求CRC-16并发送
var
    StrL:Integer; zjc:array[0..146] of char;
    CRCCode:integer;
    CRCHex:String;
begin
    CRCCode := CRC(pked, True);
    CRCHex := inttoHex(CRCCode div 4096,1)+inttoHex(CRCCode div 256 Mod 16,1)+inttoHex((CRCCode Mod 256) div 16,1)+inttoHex(CRCCode Mod 16,1);
    Strpcopy(zjc,Chr(1) + pked + CRCHex + Chr(4));
    strL:=length(Chr(1) + pked + CRCHex + Chr(4));
    ack := 0;
    sio_write(portname,@zjc,strL);   //注意
    //@@@@@@@@@@@@@@@@旧抄表器用@@@@@@@@@@@@@@@@
    {tt0 := GetTickCount;
    While (ack = 0) And ((((GetTickCount - tt0) div 1000 + 86400) Mod 86400) < 1) do
    Application.HandleMessage;}
    {delay(300);
    if ack=6 then
    begin
       packfj:=true;
       exit;
    end
    else
    begin
       ack:=0;
       sio_write(portname,@zjc,strL);
    end;
    PackFJ := false;}
    //@@@@@@@@@@@@@@@@旧抄表器用@@@@@@@@@@@@@@@@
    PackFJ := true; //新抄表器用
End;
//******************************************************************************
Function Pack(pked:String):boolean;     //打包字符串求CRC-16并发送
var
    StrL:Integer; zjc:array[0..153] of char;i:Integer;//send:pchar;
    CRCCode:integer;//tt0:integer;
    CRCHex:String;//Counter:integer;RetryNum:Integer;
begin
    //send:=nil;
    CRCCode := CRC(pked, True);
    CRCHex := chr(16*(CRCCode div 4096)+(CRCCode div 256 Mod 16))+chr(16*((CRCCode Mod 256) div 16)+(CRCCode Mod 16));
    strL:=length(Chr(1) + pked + CRCHex);
    pked:=Chr(1) + pked + CRCHex;
    for i:=1 to strL do
        zjc[i-1]:= chr(ord(pked[i]));
    ack := 0;
    sio_write(portname,@zjc,strL);
    {RetryNum:=1;
    For i := 1 To RetryNum do
    begin
        tt0 := GetTickCount;
        While (ack = 0) And ((((GetTickCount - tt0) div 10 + 86400) Mod 86400) < 5) and (pked<>'END') do
            Application.HandleMessage;
        If ack = 7 Then
        begin
            Pack := true;
            TPOC := TPOC + 1;
            Exit;
        end
        Else
        begin
            TPEC:=TPEC + 1;
            ack:=0;
        End;
    end;
    TPEC := TPEC + 1;
    Pack := false;}
    Pack := true;
End;
//******************************************************************************
function extractinf(s:string):string;
var
    i:integer;
    hchr:string;
    lchr:string;
    adds:string;
begin
    for i:=1 to 1 do
    begin
       hchr:=inttohex((ord(s[i]) shr 4),1);
       lchr:=inttohex((ord(s[i]) and 15),1);
       adds:=adds+hchr+lchr;
    end;
    result:=adds;
end;
//******************************************************************************
function extract(s:string):string;
var
    i:integer;
    hchr:string;
    lchr:string;
    adds:string;
begin
    for i:=1 to 8 do
    begin
       hchr:=inttohex((ord(s[i]) shr 4),1);
       lchr:=inttohex((ord(s[i]) and 15),1);
       adds:=adds+hchr+lchr;
    end;
    result:=adds;
end;
//******************************************************************************
function extractcure(s:string):string;
var
    i:integer;
    hchr:string;
    lchr:string;
    adds:string;
begin
    for i:=1 to 1824 do
    begin
       hchr:=inttohex((ord(s[i]) shr 4),1);
       lchr:=inttohex((ord(s[i]) and 15),1);
       adds:=adds+hchr+lchr;
    end;
    result:=adds;
end;
end.