phoenixusb.dpr

来自「Usb CardMaster Phoenix SDK」· DPR 代码 · 共 436 行

library PhoenixUSB;

{ 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, CmDriver, SetupApi, Windows,
  Classes, Messages, StrUtils;

{$R *.res}

const
  CMGuid: TGUID = '{17A6AB54-7DD3-4027-9262-90B40C59902B}';
  BR9600: Integer = 0;
  BR9895: Integer = 1;
type
  TUSBPackage = array [0..8-1] of char;

function ReadFileEx(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD;
  var Overlapped: TOverlapped; lpCompletionRoutine: TPROverlappedCompletionRoutine): BOOL; cdecl;
  external 'kernel32.dll' name 'ReadFileEx';
function WriteFileEx(hFile: THandle; var Buffer; nNumberOfBytesToWrite: DWORD;
  var Overlapped: TOverlapped; lpCompletionRoutine: TPROverlappedCompletionRoutine): BOOL; cdecl;
 external 'kernel32.dll' name 'WriteFileEx';

var
  DevHandle: THandle;
  Connected: boolean;
  Protocol: Integer;
  BaudRate: Integer;
  InBuffer: Array [0..2048] of char;
  InLen,InTimer: Integer;
  TimerRunning: Boolean;

procedure emptyBuffer;
var
  i: Integer;
begin
  for i:=0 to 2048 do
    InBuffer[i] := Char(0);
end;

procedure RemoveFromBuff(l: Integer);
var
  i: Integer;
begin
  for i:=0 to (2048-l) do
  begin
    inBuffer[i] := inBuffer[i+l];
  end;
  inLen := inLen-l;
  if inLen < 0 then
    inLen := 0;
end;

function StringToPack(s: String): TUSBPackage;
var
  t,i,j,k: Integer;
begin
  for i:=0 to 7 do
    Result[i] := Char(0);
  t := StrToInt(s[1] + s[2]);
  Result[0] := Char(t);
  j := 3;
  k := 1;
  repeat
    Result[k] := Char(StrToInt('$' + s[j] + s[j+1]));
    Dec(t);
    Inc(k);
    Inc(j,2);
  until t<=0;
end;

function PhoenixToSmartMouse(s: String): TUSBPackage;
var
  t,i,j,k: Integer;
  c: Char;
begin
  for i:=0 to 7 do
    Result[i] := Char(0);
  t := StrToInt(s[1] + s[2]);
  Result[0] := Char(t);
  j := 3;
  k := 1;
  repeat
    Result[k] := Char(StrToInt('$' + s[j] + s[j+1]));
    c := Result[k];
    Result[k] := Char(0);
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 1) shl 7));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 2) shl 5));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 4) shl 3));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 8) shl 1));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 16) shr 1));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 32) shr 3));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 64) shr 5));
    Result[k] := Char(Integer(Result[k]) or ((Integer(c) and 128) shr 7));
    Result[k] := Char(not Integer(Result[k]));
    Dec(t);
    Inc(k);
    Inc(j,2);
  until t<=0;
end;

function sendIOCTL_out(res: array of char; code: Cardinal): boolean; overload;
var
  buff: PByteArray;
  buffSize: Cardinal;
  i: Integer;
  retries: Integer;
begin
  getmem(buff,9);
  for i:=0 to 7 do
    buff[i] := Byte(res[i]);
  Result := false;
  buffSize := 8;
  retries := 0;
  code := getIoctlFromCode(code);
  repeat
  if DeviceIOControl(DevHandle,code,buff,buffSize,buff,buffSize,buffSize,nil) then
    Result := true;
  until (Result=true) or (retries>2);
  freemem(buff);
end;

function sendIOCTL_out(state: Word; code: Cardinal): boolean; overload;
var
  buffSize: Cardinal;
  s: Word;
  retries: Integer;
begin
  s := state;
  retries := 0;
  Result := false;
  code := getIoctlFromCode(code);
  repeat
    if DeviceIOControl(DevHandle,code,@s,2,@s,2,buffSize,nil) then
      Result := true;
    inc(retries);
  until (Result=true) or (retries>2);
end;

function sendIOCTL_in(code: Cardinal; var res: String; len: Integer): boolean;
var
  buff: array [0..16] of byte;
  buffSize: Cardinal;
  i: Integer;
begin
  Result := true;
  res := '';
  buffSize := len;
  for i:=0 to len do
    buff[i] := Byte(0);
  code := getIoctlFromCode(code);
  if DeviceIOControl(DevHandle,code,@(buff[0]),buffSize,@(buff[0]),len,buffSize,nil) then
  begin
    for i:=0 to buffSize-1 do
      res := res + IntToHex(byte(buff[i]),2);
  end
  else
    Result := false;
end;

procedure WMTimer(var message: TMessage);
var
  tmp: String;
  inPack: TUSBPackage;
  i: Integer;
begin
  sendIOCTL_in(IOCTL_OUT_EXECUTE_READ,tmp,8);
  if Protocol = 0 then
    inPack := PhoenixToSmartMouse(tmp)
  else
    inPack := StringToPack(tmp);
  if (Byte(inPack[0])>0) then
  begin
    for i:=1 to Byte(inPack[0]) do
    begin
      inBuffer[InLen] := inPack[i];
      Inc(InLen);
    end;
  end;
end;

//*********************************************************
//*********************************************************

function findDevice: boolean;
var
  devInfo: HDEVINFO;
  reqLen,noUse: DWORD;
  interfaceData: SP_DEVICE_INTERFACE_DATA;
  interfaceDetail: PSPDeviceInterfaceDetailData;
begin
  try
    devInfo := SetupDiGetClassDevs(@CMGuid,nil,0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE);
    interfaceData.cbSize := SizeOf(interfaceData);
    SetupDiEnumDeviceInterfaces(devInfo,nil,CMGuid,0,interfaceData);
    SetupDiGetDeviceInterfaceDetail(devInfo,@interfaceData,nil,0,reqLen,nil);
    getMem(interfaceDetail,reqLen);
    interfaceDetail.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
    SetupDiGetDeviceInterfaceDetail(devInfo,@interfaceData,interfaceDetail,reqLen,noUse,nil);
    DevHandle := CreateFile(interfaceDetail.DevicePath,GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,0, 0);
    FreeMem(interfaceDetail);
    SetupDiDestroyDeviceInfoList(devInfo);
    Result := true;
  except
    Result := false;
  end;
end;

//*********************************************************

procedure SetProtocol(p: Integer); cdecl;
var
  val: Integer;
begin
  if p > 0 then
    Protocol := 1
  else
    Protocol := 0;
  if Connected then
  begin
    if Protocol = 1 then
      val := $7
    else
      val := $8;
    sendIOCTL_out(val,IOCTL_OUT_SET_CHIP);
  end;
end;

//*********************************************************

function Connect: Cardinal; cdecl;
begin
  if not IsSetupApiLoaded then
    LoadSetupApi;
  if findDevice then
  begin
    Result := 1;
    Connected := true;
  end
  else
  begin
    Result := 0;
    Connected := false;
  end;
  TimerRunning := false;
end;

//*********************************************************

procedure Disconnect; cdecl;
begin
  if IsSetupApiLoaded then
    UnloadSetupApi;
  Connected := False;
end;

//*********************************************************

procedure setBaudRate(br: Integer); cdecl;
var
  sendStartBitDelay, sendBitDelay, sendParityDelay: Integer;
  recStartDelay, recDelay: Integer;
  etuDelay: Integer;
  val: Word;
begin
  BaudRate := br;
  if Connected then
  begin
//    case br of
//    0:
//      begin
        sendStartBitDelay := 135;
        sendBitDelay := 132;
        sendParityDelay := 133;
        recStartDelay := 54;
        recDelay := 132;
        etuDelay := 138;
{      end;
    1:
      begin
        sendStartBitDelay := 130;
        sendBitDelay := 126;
        sendParityDelay := 130;
        recStartDelay := 52;
        recDelay := 128;
        etuDelay := 134;
      end;
    else
      begin
        sendStartBitDelay := 135;
        sendBitDelay := 132;
        sendParityDelay := 133;
        recStartDelay := 54;
        recDelay := 132;
        etuDelay := 138;
      end;
    end;}
    val := sendStartBitDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
    val := $0100 + sendBitDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
    val := $0200 + sendParityDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
    val := $0300 + recStartDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
    val := $0400 + recDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
    val := $0500 + etuDelay;
    sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_DELAY);
  end;
end;

procedure greenOn; cdecl;
begin
  sendIOCTL_out(0,IOCTL_OUT_LIGHT_GREEN_ON);
end;

procedure greenOff; cdecl;
begin
  sendIOCTL_out(0,IOCTL_OUT_LIGHT_GREEN_OFF);
end;

procedure redOn; cdecl;
begin
  sendIOCTL_out(0,IOCTL_OUT_LIGHT_RED_ON);
end;

procedure redOff; cdecl;
begin
  sendIOCTL_out(0,IOCTL_OUT_LIGHT_RED_OFF);
end;

procedure transmit(data: pchar; len: integer); cdecl;
var
  i,sendsize,pos: Integer;
  outpack: TUSBPackage;
begin
  pos := 0;
  repeat
    if len > 7 then
      sendsize := 7
    else
      sendsize := len;
    outpack[0] := Char(sendsize);
    for i:=sendsize downto 1 do
    begin
      outpack[i] := Char(StrToInt('$' + data[pos] + data[pos+1]));
      inc(pos,2);
    end;
    sendIOCTL_out(outPack,IOCTL_OUT_EXECUTE_WRITE);
    len := len - sendsize;
  until len <= 0;
end;

function receive(buff: PChar; len: integer): Integer; cdecl;
var
  i,getlen: Integer;
  tstr: String;
begin
  if len > InLen then
    getlen := InLen
  else
    getlen := len;
  for i:=0 to getlen-1 do
  begin
    tstr := IntToHex(Byte(inBuffer[i]),2);
    buff[i*2] := tstr[1];
    buff[i*2+1] := tstr[2];
    buff[i*2+2] := Char(0);
  end;
  RemoveFromBuff(getlen);
//  buff[0] := 'T';
//  buff[1] := 'E';
//  buff[2] := Char(0);
  Result := getlen;
end;

procedure setParity(val: char); cdecl;
begin
  sendIOCTL_out(val,IOCTL_OUT_SET_PHOENIX_PARITY);
end;

procedure reset;
var
  tmp : string;
begin
  setParity(Char($ff));
  emptyBuffer;
  if (TimerRunning) then
    KillTimer(0,InTimer);
  InLen := 0;
  sendIOCTL_out(1,IOCTL_OUT_SET_OSC);
  sleep(5);
  setBaudRate(0);
  sleep(5);
  sendIOCTL_out(2,IOCTL_OUT_SET_DELAY);
  sleep(5);
  sendIOCTL_out(8,IOCTL_OUT_SET_CHIP);
  sleep(5);
  sendIOCTL_out(2,IOCTL_OUT_SET_VOLTAGE);
  sleep(5);
  sendIOCTL_in(IOCTL_OUT_EXECUTE_READ,tmp,8);
  sendIOCTL_out(0,IOCTL_OUT_SET_VOLTAGE);
//  sleep(5);
//  sleep(50);

  SetTimer(0,InTimer, 100, @WMTimer);
  TimerRunning := true;
end;

exports
  Connect,
  Disconnect,
  SetProtocol,
  setBaudRate,
  transmit,
  receive,
  reset,
  greenOn,
  greenOff,
  redOn,
  redOff,
  setParity;

end.