ucipherlab8000.pas

欣技8000c 的delphi通讯接口,没有DLL文件

unit UCipherlab8000;


interface

uses Classes,Windows;

type

  TCOMPorts=(cpCOM1,cpCOM2,cpCOM3,cpCOM4,cpCOM5,cpCOM6,cpCOM7,cpCOM8,cpCOM9);

  TBauds=(bd9600,bd19200,bd38400,bd57600,bd115200);

  TCipherLab8000=class(TComponent)
  protected
    hComm:Thandle;          // the handle of the opened Comm Device.
    cInBuf: array [0..255] of char;        // Input buffer for receiving data.
    szBuf: array [0..255] of char;         // Record Buffer.
    szIR:lpstr; //array [0..7] of byte;            // for IR command
    TimeOuts:COMMTIMEOUTS;
    dcb:TDCB;
    nChar:DWORD;
    nDlyTime:byte;        //=200 delay time for DIP switch cradle, 2004.02.20
    crc1v,crc2v:integer;
    procedure CloseIrCom;
    procedure WriteIrCom(lpStr:LPSTR);
    function OpenIrCom (nPort,nBaud:integer):THandle;
    function ReadIrCom:string;
    function FillDCB(nBaud:integer):boolean;
    function TestIR(spec:dword):boolean;
  private
    FComport: TCOMPorts;
    FActive: boolean;
    FBaud: TBauds;
    FOnRecivedALine: TNotifyEvent;
    FOnSentALine: TNotifyEvent;
    procedure SetComport(const Value: TCOMPorts);
    procedure SetActive(const Value: boolean);
    procedure SetBaud(const Value: TBauds);
    procedure SetOnRecivedALine(const Value: TNotifyEvent);
    procedure SetOnSentALine(const Value: TNotifyEvent);
  public
    LastError:string;
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    function Open:boolean;
    function ReceiveDataToStrings(Strings:TStrings):boolean;
    function ReceiveDataToFile(FileName:string):boolean;
    function ReceiveDataToStream(Stream:TStream):boolean;
    function SendLookupFromStrings(Strings:TStrings):boolean;
    procedure Close;
  published
    property Comport:TCOMPorts read FComport write SetComport default cpCOM1;
    property Active:boolean read FActive write SetActive default false;
    property Baud:TBauds read FBaud write SetBaud default bd38400;
    property OnRecivedALine:TNotifyEvent read FOnRecivedALine write SetOnRecivedALine;
    property OnSentALine:TNotifyEvent read FOnSentALine write SetOnSentALine;
  end;

  procedure Register;

implementation

uses SysUtils;

const
szComPort:array [0..8] of string = ('COM1', 'COM2', 'COM3', 'COM4',
                            'COM5', 'COM6', 'COM7', 'COM8', 'COM9');
                            
szBauds:array [0..4] of integer= (9600,19200,38400,57600,115200);


fBinary = $0001; // Not valid in Win32.
fParity = $0002; // When set, parity checking is enabled.
fOutxCtsFlow = $0004; // No data sent unless CTS is high.
fOutxDsrFlow = $0008; // No data sent unless DSR is high.
fDtrControl = $0010; // DTR_CONTROL_ENABLE, DTR_CONTROL_DISABLE, DTR_CONTROL_HANDSHAKE
fDsrSensitivity = $0040;//$0012; // Unless DSR is high, all bytes ignored.
fTxContinueOnXOff = $0080;//$0014; // Can continue sending data, even when waiting on an XON character to be set. If not set, cannot send data until XONLim is reached.
fOutX = $0100;//$0018; // XON/XOFF flow control enabled for sending.
fInX = $0200;//$0020; // XON/XOFF flow control enabled for receiving.
fErrorChar = $0400;//$0021; // If a parity error is detected, the error will be replaced with this character.
fNull = $0800;//$0022; // Strip off the null characters.
fRtsControl = $1000;//$0024;
fAbortOnError = $4000;//$0030;

type
  ECipherLabException = class(Exception);


procedure Register;
begin
    RegisterComponents('Cipherlab 8000',[TCipherLab8000]);

end;


function TCipherLab8000.OpenIrCom(nPort,nBaud:integer):THandle;
begin
  hComm:=CreateFile(PCHAR(szComPort[nPort]), GENERIC_READ or GENERIC_WRITE,
                 0, nil, OPEN_EXISTING, 0, 0);
  result:=0;
  if hcomm = INVALID_HANDLE_VALUE then
       begin
           LastError:='Can not open the COM port!';
           raise ECipherLabException.Create(LastError);
         exit;
       end;

   SetupComm(hComm, 256, 256);       // allocate transmit & receive buffer

   if (not FillDCB(szbauds[nBaud])) then
       begin
          CloseHandle (hComm);
          LastError:='Can not configure the port!';
          raise ECipherLabException.Create(LastError);

         exit;
       end;

   if not SetCommState(hComm, dcb) then
       begin
          CloseHandle (hComm);
          LastError:='Can not initialize the COM port!';
          raise ECipherLabException.Create(LastError);

          hComm := 0;
       exit;
       end;

   TimeOuts.ReadIntervalTimeout := MAXDWORD;
   TimeOuts.ReadTotalTimeoutMultiplier := 0;
   TimeOuts.ReadTotalTimeoutConstant := 0;
   TimeOuts.WriteTotalTimeoutMultiplier := 5;
   TimeOuts.WriteTotalTimeoutConstant := 50;
   SetCommTimeouts (hComm, TimeOuts);           // check dwProvCapabilities

   result:=hComm;
end;

procedure TCipherLab8000.CloseIrCom;
begin
   if (not (hComm = INVALID_HANDLE_VALUE)) and (not (hComm = 0)) then
      begin
       CloseHandle (hComm);                      // close the COM Port.
       hComm := 0;
      end;
end;

procedure TCipherLab8000.WriteIrCom(lpStr:LPSTR);
var
nChar, nCount: DWORD ;
const
EMZeroChar:PAnsiChar=#0#13;
begin
   nCount := lstrlen (lpStr);
   WriteFile(hComm, lpStr^, nCount, nChar, nil);

  if lpstr[nCount-1]<>#13 then
   WriteFile (hComm, EMZeroChar^, 2, nChar, nil);

end;

function TCipherLab8000.ReadIrCom:string;
var
i,nCount,nChar:cardinal;
cRet:char;
dwTime0:DWORD;
begin
   dwTime0:= GetTickCount();
   nCount:= 0;                                         // reset char counter
   cRet:= #0;
   Result:='';
   szBuf[0]:=#0;
   
   while not (cRet =#13) do     // while not get the return char keep on reading
     begin
       if (ReadFile(hComm, cInBuf, 1, nChar, nil)) then
         begin
          if nchar>0 then
          begin
           for i:=0 to nChar-1 do
            if (nCount < 255) then
               begin
                 szBuf[nCount]:= cInBuf[i];
                 inc(nCount);
               end;

           cRet:=cInBuf[i-1];
          end;
         end;

        if (GetTickCount() - dwTime0 > 5000) then           // check if time out
           begin
           //  MessageBox (GetActiveWindow(), 'Time out!', 'Error', MB_OK);
             Lasterror:='Time out!';
             raise ECipherLabException.Create(LastError);
             exit;
           end;
     end;

   if ncount>0 then
     szBuf[nCount-1] := #0;

   if (szBuf[0]<#10) and (ncount<>0) then
      szbuf[0]:=chr(ord(szbuf[0])+48);

  if ncount>2 then
   begin
    crc1v:=ord(szBuf[nCount-2]);
    crc2v:=ord(szBuf[nCount-3]);
   end;

   Result:=szBuf;

end;

function TCipherLab8000.FillDCB(nBaud:integer):boolean;
begin
    GetCommTimeouts (hComm, TimeOuts);
    TimeOuts.ReadIntervalTimeout := MAXDWORD;
    TimeOuts.ReadTotalTimeoutMultiplier := 0;
    TimeOuts.ReadTotalTimeoutConstant := 0;
    TimeOuts.WriteTotalTimeoutMultiplier := 5;
    TimeOuts.WriteTotalTimeoutConstant := 50;
    SetCommTimeouts (hComm, TimeOuts);

    dcb.BaudRate := 38400;
    dcb.ByteSize := 8;
    dcb.Parity := NOPARITY;
    dcb.StopBits := ONESTOPBIT;

//    dcb.Flags:=dcb.Flags or RTS_CONTROL_ENABLE or DTR_CONTROL_ENABLE;

//    dcb.Flags:=dcb.Flags or (fRtsControl * RTS_CONTROL_ENABLE) or (fDtrControl * DTR_CONTROL_ENABLE);

    // set RTS on (low!)
    // set DTR on (low!)

    dcb.flags:=dcb.flags or fRtsControl;
    dcb.flags:=dcb.flags or fDtrControl;

    SetCommState (hComm, dcb);                  // get power from DTR

    Sleep (nDlyTime);

    if (TestIR (CBR_9600)) then                      // test current baud rate
        dcb.BaudRate := CBR_9600
    else if (TestIR (CBR_38400)) then
        dcb.BaudRate := CBR_38400
    else if (TestIR (CBR_115200)) then
        dcb.BaudRate := CBR_115200
    else if (TestIR (CBR_57600)) then
        dcb.BaudRate := CBR_57600
    else if (TestIR (CBR_19200)) then
        dcb.BaudRate := CBR_19200
    else
        Result:=false;

    dcb.flags:=dcb.flags and not fRtsControl;       // set RTS off (high!)

    SetCommState (hComm, dcb);
    Sleep (nDlyTime);

    szIR := #7;

    WriteFile(hComm, szIR^, 1, nChar, nil);    // disable Echo
    Sleep (nDlyTime);

    if (nBaud = 115200) then
       begin
          dcb.BaudRate:= CBR_115200;
          szIR:= #$36;
       end
    else if (nBaud = 57600) then
        begin
          dcb.BaudRate:= CBR_57600;
          szIR:= #$35;
        end
    else if (nBaud = 38400) then
        begin
          dcb.BaudRate:= CBR_38400;
          szIR:= #$34;
        end
    else if (nBaud = 19200) then
        begin
          dcb.BaudRate := CBR_19200;
          szIR:= #$33;
        end
    else                                         // use default value:9600
        begin
        dcb.BaudRate := CBR_9600;
        szIR:= #$32;
        end;

    WriteFile(hComm, szIR^, 1, nChar, nil);    // set to new baud rate
    Sleep(nDlyTime);

    szIR:= #$51;
    WriteFile(hComm, szIR^, 1, nChar, nil);    // load new baud rate
    Sleep(nDlyTime);

//    dcb.fRtsControl = RTS_CONTROL_ENABLE;        // set RTS on (low!)
    dcb.flags:=dcb.flags or fRtsControl;          // set RTS on (low!)

    SetCommState (hComm, dcb);
    Sleep (nDlyTime);

    dcb.Parity := NOPARITY;
    dcb.ByteSize := 8;

    dcb.flags:=dcb.flags and not fOutxCtsFlow;                    // no flow control
    dcb.flags:=dcb.flags and not fOutX;

    result:=true;
end;


function TCipherLab8000.TestIR(spec:dword):boolean;
var
szIn:array [0..3] of byte;
nChar, dwTime:dword;
nRtn:boolean;
begin
    Result:=false;
    dcb.BaudRate := spec;

    dcb.flags:=dcb.flags and not fRtsControl;       // set RTS off (high!)

    SetCommState (hComm, dcb);
    Sleep (nDlyTime);

  	szIR := #$0f;                                // set Control register 1
   	WriteFile (hComm, szIR^, 1, nChar, nil);
    Sleep (nDlyTime);

    dwTime := GetTickCount();
    nRtn := false;
    while (GetTickCount() - dwTime < 100) do        // 100 msec
		begin
 		 if (ReadFile (hComm, szIn, 1, nChar, nil)) then // waiting for echo
		  	begin
	  	  	if (szIn[0] = $0f) then                   // receive the same char
              nRtn := true;
          	break;
   			end;
		end;

//	dcb.fRtsControl = RTS_CONTROL_ENABLE;        // set RTS on (LOW !!)
  dcb.flags:=dcb.flags or fRtsControl;       // set RTS on (LOW !!)

	SetCommState (hComm, dcb);
  Sleep (nDlyTime);
  nDlyTime := 100;    // 2004.02.20, for DIP switch cradle, set to 100 except 9600bps
	result:= nRtn;
end;

constructor TCipherLab8000.Create(AOwner: TComponent);
begin
  inherited;
  nDlyTime:=200;
  Active:=false;
  Baud:=bd38400;
  Comport:=cpCOM1;

end;

destructor TCipherLab8000.Destroy;
begin
  Active:=false;
  inherited;
end;

procedure TCipherLab8000.SetComport(const Value: TCOMPorts);
begin
  if Active then Active:=false;
  FComport := Value;
end;


procedure TCipherLab8000.SetActive(const Value: boolean);
begin

 if Value=FActive then exit;

 if Value then
  begin
   try
    hcomm:=OpenIrCom(byte(Comport),byte(Baud));
   except
     if csDesigning  in Componentstate then
       MessageBox(GetActiveWindow(),PAnsiChar(LastError),
          'Error', MB_OK or MB_ICONEXCLAMATION);

     CloseIrCom;
     HComm:=0;
     FActive := False;
     exit;
   end;

  FActive := Value;
  end else
  begin
    CloseIrCom;
    FActive := Value;
  end;

end;

procedure TCipherLab8000.SetBaud(const Value: TBauds);
begin
  if Active then Active:=false;
  FBaud := Value;
end;

function TCipherLab8000.Open: boolean;
begin
  Active:=true;
  Result:=Active;
end;

procedure TCipherLab8000.Close;
begin
  Active:=false;
end;

function TCipherLab8000.ReceiveDataToStrings(Strings:TStrings):boolean;
var
s:string;
m,a,sit,lid:integer;
crcok:boolean;
begin
  WriteIrCom('READ'+#13);
  lid:=0;
  Strings.Clear;
  Result:=true;
 try
  if ReadIrCom='ACK' then
  while true do
   begin
     s:=ReadIrCom;

     if s<>'OVER' then
      begin
        crcok:=false;
        if (strtoint(s[1])>=lid) or (lid=9) then
         begin
           sit:=0;
           m:=0;

           if crc2v=0 then
            m:=2 else
             if crc1v=0 then
              m:=1;
           s:=copy(s,1,length(s)-(2-m));

           for a:=2 to length(s) do
            sit:=sit+ord(s[a]);

           sit:=sit+strtoint(copy(s,1,1));

           if (sit div 256)<>13 then
            crcok:=(sit div 256)=crc1v else
            crcok:=crc1v=14;

           if (sit mod 256)<>13 then
            crcok:=crcok and ((sit mod 256)=crc2v) else
            crcok:=crcok and (crc2v=14);
                             
          if crcok then
            lid:=strtoint(copy(s,1,1));

         end else
           crcok:=true;

        if crcok then
         begin
          Strings.Add(copy(s,2,length(s)-1));
          WriteIrCom('ACK'+#13);
          if Assigned(FOnRecivedALine) then FOnRecivedALine(Self);
         end else
          WriteIrCom('NAK'+#13);

      end else
       break;

   end;
  except
    Result:=false;
  end;

end;

function TCipherLab8000.ReceiveDataToFile(FileName:string): boolean;
var
sl:TStringList;
begin
  sl:=TStringList.Create;
  Result:=ReceiveDataToStrings(sl);

  if Result then sl.SaveToFile(Filename);

  sl.Free;
end;

function TCipherLab8000.ReceiveDataToStream(Stream: TStream): boolean;
var
sl:TStringList;
begin
  sl:=TStringList.Create;
  Result:=ReceiveDataToStrings(sl);

  if Result then sl.SaveToStream(Stream);

  sl.Free;
end;

function TCipherLab8000.SendLookupFromStrings(Strings: TStrings): boolean;
var
sit,sut,sat,a,b:integer;
ack,s:string;
begin
  WriteIrCom('CIPHER'+#13);

  Result:=true;
 try
  if ReadIrCom='ACK' then
   begin
    for b:=0 to Strings.Count-1 do
     begin
       s:=Strings.Strings[b];

       sit:=0;
       for a:=1 to length(s) do
          sit:=sit+ord(s[a]);

       sat:=sit div 256;
       sut:=sit mod 256;

       if sat=13 then sat:=14;

       if sut=13 then sut:=14;

       ack:='';
       while ack<>'ACK' do
        begin
         WriteIrCom(PChar(s+chr(sat)+chr(sut)+#13));
         ack:=ReadIrCom;
        end;
       if Assigned(FOnSentALine) then FOnSentALine(Self);
     end;

    WriteIrCom(PChar('OVER'+#13));
   end;
  except
    Result:=false;
  end;

end;

procedure TCipherLab8000.SetOnRecivedALine(const Value: TNotifyEvent);
begin
  FOnRecivedALine := Value;
end;

procedure TCipherLab8000.SetOnSentALine(const Value: TNotifyEvent);
begin
  FOnSentALine := Value;
end;

end.