盒子论坛 v2.1

该控件只能在98下使用，要修改那里才可以在WIN2000上也可以用？
在2000下使用不会报错，只是写卡器的灯不亮，所以不能进行读、写操作。
我也不知道哪里还要再改一下~~`

unit CardComm;

////////////////////////////////////////////////////////////////////////////////
//
//    本控件是封装了读写磁卡底层操作的控件。提供以下函数。
//    function InitCard: Boolean;
//       初始化COM通讯口并复位卡，不成功返回False。
//    function ResetCard: Boolean;
//       软复位，不成功返回False。
//    function HardResetCard: Boolean;
//       复位，不成功返回False。
//    function ReadCard: String;
//       读出卡内字符串（有多少读多少），返回空字符串表示出错或者什么都没读到。
//    function WriteCardVerify(s: String): Boolean;
//       把字符串写入卡内，接着读出来进行校验，不成功返回False。
//    function WriteCardWithoutVerify(s: String): Boolean;
//       把字符串写入卡内，不进行校验，不成功返回False。
//    procedure Cancel;
//       在进行以上操作的时候Cancel掉（不一定管用）。
//
//    属性：ComPort：设置是COM1口还是COM2还是COM3还是COM4
//          BaudRate：波特率，默认9600，别乱改
//          TimeOut：读写出错时的反复重试的时间秒数。
//
//
//
//
//
////////////////////////////////////////////////////////////////////////////////

interface

uses
  Windows, Messages, SysUtils, Classes, Forms;

const
  MAXLENGTH = 37;

type
  TComPort = ( cpCOM1, cpCOM2, cpCOM3, cpCOM4 );

type
  ECardError = class(Exception);

type
  TCardCommunicator = class(TComponent)
  private
    FComPort: TComPort;
    FCOMPortStr: String;
    FComHandle: THandle;
    FBaudRate: Integer;
    FCancel: Boolean;
    FTimeOut: DWord;
    procedure SetComPort(const Value: TComPort);
    procedure SetBaudRate(const Value: Integer);
    procedure SetTimeOut(const Value: DWord);
    { Private declarations }
  protected
    function InitCom(ComStr: PChar; var ComHandle: THandle; BaudRate: Integer): Boolean;
    function CloseCom(ComHandle: THandle): Boolean;
    function SimpleReadCard(var Length: DWord): String;
    // 内部使用，读简单的字符串，直到正确读入COM口为止。
    function SimpleWriteCard(RawStr: String): Boolean;
    // 内部使用，写简单的字符串，直到正确写入COM口为止。
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function InitCard: Boolean;
    function CloseCard: Boolean;
    function ResetCard: Boolean;
    function HardResetCard: Boolean;
    function ReadCard: String;
    function WriteCardVerify(s: String): Boolean;
    function WriteCardWithOutVerify(s: String): Boolean;
    procedure Cancel;
    { Public declarations }
  published
    property ComPort: TComPort read FComPort write SetComPort;
    property BaudRate: Integer read FBaudRate write SetBaudRate;
    property TimeOut: DWord read FTimeOut write SetTimeOut;
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Cards', [TCardCommunicator]);
end;

{ TCardCommunicator }

procedure TCardCommunicator.Cancel;
begin
  Self.FCancel := True;
end;

function TCardCommunicator.CloseCard: Boolean;
begin
  if Self.FComHandle <> 0 then
  begin
    Self.ResetCard;
    Self.CloseCom(Self.FComHandle);
  end;
end;

function TCardCommunicator.CloseCom(ComHandle: THandle): Boolean;
begin
  Result := CloseHandle(ComHandle);
end;

constructor TCardCommunicator.Create(AOwner: TComponent);
begin
  inherited;
  Self.FComPort := cpCOM1;
  Self.FBaudRate := 9600;
  Self.FTimeOut := 30;
end;

destructor TCardCommunicator.Destroy;
begin
  Self.CloseCard;
  Self.FComHandle := 0;
  inherited;
end;

function TCardCommunicator.HardResetCard: Boolean;
var
  SendStr: array[0..1] of Byte;
  ByteNum: DWord;
  Err: Boolean;
begin
  SendStr[0] := $1B;
  SendStr[1] := $53;
  Err := False;
  if Self.FComHandle <> INVALID_HANDLE_VALUE then
  begin
    while (not Err) and (ByteNum <> 2) and (not Self.FCancel) do
    begin
      Err := WriteFile(FComHandle, SendStr, 2, ByteNum, nil);
      Application.ProcessMessages;
    end;
    Self.FCancel := False;
    Result := Err;
  end
  else
    Result := False;

end;

function TCardCommunicator.InitCard: Boolean;
begin
  if Self.FCOMPortStr <> '' then
  begin
    if Self.FComHandle = 0 then
      if not Self.InitCom(PChar(Self.FCOMPortStr), Self.FComHandle, Self.FBaudRate) then
      begin
        Result := False;
        Exit;
      end;
    Result := Self.ResetCard;
  end;
end;

function TCardCommunicator.InitCom(ComStr: PChar; var ComHandle: THandle;
  BaudRate: Integer): Boolean;
var
  tOut: COMMTIMEOUTS;
  ComDcb: DCB;
begin
  ComHandle := CreateFile(ComStr, GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE,
    nil, OPEN_EXISTING, 0, 0);
  if ComHandle = INVALID_HANDLE_VALUE then //句柄检查
  begin
    Result := False;
    exit;
  end;
  if not GetCommState(ComHandle, ComDcb) then //DCB检查
  begin
    Result := False;
    exit;
  end;
  ComDcb.BaudRate := BaudRate; //波特率设置
  if not SetCommState(ComHandle, ComDcb) then
  begin
    Result := False;
    exit;
  end;
// 通讯超时设置
  GetCommTimeouts(ComHandle, tout);
  tOut.ReadIntervalTimeout := 100;
  tOut.ReadTotalTimeoutMultiplier := 100;
  tOut.ReadTotalTimeoutConstant := 100;
  SetCommTimeouts(ComHandle, tOut);
  EscapeCommfunction(ComHandle, CLRDTR);
  Result := True;
end;

// 读卡这一个函数基本上没什么错误了。

function TCardCommunicator.ReadCard: String;
var
  SendStr: array[0..1] of Char;
  BackStr: String;
  Err: Boolean;
  ByteNum, Len, iTime, i: DWord;
begin
  if not Self.ResetCard then
  begin
    Result := '';
    Exit;
  end;

  SendStr[0] := #$1B;
  SendStr[1] := #$5D;
  if not Self.SimpleWriteCard(SendStr) then
  begin
    Result := '';
    Exit;
  end;

  Err := False;
  Len := MAXLENGTH;
  iTime := GetTickCount;
  while (not Err) and (not Self.FCancel) and (GetTickCount < iTime + Self.FTimeOut * 1000) do
  begin
    Len := MAXLENGTH;
    BackStr := Self.SimpleReadCard(Len);
    Err := (BackStr <> '') and (Len > 0);
    Application.ProcessMessages;
  end;

  if Self.FCancel then Self.ResetCard;
  i := Pos(#$3F, BackStr);
  if i > 4 then
    Result := Copy(BackStr, 3, i - 3)
  else
    Result := '';
end;

function TCardCommunicator.ResetCard: Boolean;
var
  SendStr: array[0..1] of Byte;
  ByteNum: DWord;
  Err: Boolean;
begin
  SendStr[0] := $1B;
  SendStr[1] := $30;
  Err := False;
  if Self.FComHandle <> INVALID_HANDLE_VALUE then
  begin
    while (not Err) and (ByteNum <> 2) and (not Self.FCancel) do
    begin
      Err := WriteFile(FComHandle, SendStr, 2, ByteNum, nil);
      Application.ProcessMessages;
    end;
    Self.FCancel := False;
    Result := Err;
  end
  else
    Result := False;
end;

procedure TCardCommunicator.SetBaudRate(const Value: Integer);
begin
  FBaudRate := Value;
end;

procedure TCardCommunicator.SetComPort(const Value: TComPort);
begin
  FComPort := Value;
  case Value of
    cpCOM1: Self.FCOMPortStr := 'COM1';
    cpCOM2: Self.FCOMPortStr := 'COM2';
    cpCOM3: Self.FCOMPortStr := 'COM3';
    cpCOM4: Self.FCOMPortStr := 'COM4';
  end;
end;

procedure TCardCommunicator.SetTimeOut(const Value: DWord);
begin
  if Value > 0 then
    FTimeOut := Value;
end;

function TCardCommunicator.SimpleReadCard(var Length: DWord): String;
var
  BackStr: array[1..MAXLENGTH] of Char;
  ByteNum: DWord;
  Err: Boolean;
begin
  if (Length > 0) and (Self.FComHandle <> INVALID_HANDLE_VALUE) then
  begin
    Err := False;
    FillChar(BackStr, MAXLENGTH, 0);
    while (not Err) and (not Self.FCancel) do
    begin
      Err := ReadFile(Self.FComHandle, BackStr, Length, ByteNum, Nil);
      Application.ProcessMessages;
    end;
    if Self.FCancel then Self.ResetCard;
    Length := ByteNum;
    Result := BackStr;
  end
  else
    Result := '';
end;

// 该函数已经修改

function TCardCommunicator.SimpleWriteCard(RawStr: String): Boolean;
var
  Err: Boolean;
  ByteNum, Len: DWord;
  Buf: array[0..MAXLENGTH] of Byte;
begin

  Err := False;
  ByteNum := 0;
  Len := Length(RawStr);
  if Len > MAXLENGTH then Len := MAXLENGTH;
  FillChar(Buf, MAXLENGTH, 0);
  CopyMemory(@Buf, Pointer(RawStr), Len);
  if Self.FComHandle <> INVALID_HANDLE_VALUE then
  begin
    while ((not Err) or (ByteNum <> Len)) and (not Self.FCancel) do
    begin
      Err := WriteFile(Self.FComHandle, Buf, Len, ByteNum, nil);
      Application.ProcessMessages;
    end;
    if Self.FCancel then Self.ResetCard;
    Result := Err;
  end
  else
    Result := False;
end;

function TCardCommunicator.WriteCardVerify(s: String): Boolean;
var
  SendStr: array[0..MAXLENGTH - 1] of Char;
  BackStr: String;
  Err: Boolean;
  i, j, ByteNum: Integer;
  iTime, Len, OldLen, iRTime: DWord;
begin
  if not Self.ResetCard then
  begin
    Exit;
  end;

  i := Length(s);
  if (i = 0) or (i > MAXLENGTH) then
  begin
    Result := False;
    Exit;
  end;

  Len := i + 5;
//  SetLength(SendStr, Len);
//  SetLength(BackStr, Len);

  SendStr[0] := #$1B;
  SendStr[1] := #$74;
  for j := 1 to i do SendStr[j + 1] := s[j];
  SendStr[Len - 3] := #$1D;
  SendStr[Len - 2] := #$1B;
  SendStr[Len - 1] := #$5C;

  iTime := GetTickCount;
  Err := False;
  OldLen := Len - 1;
  Dec(Len);
  while (Err and not Self.FCancel) or (GetTickCount < iTime + Self.FTimeOut * 1000) do
  begin
    if not Self.SimpleWriteCard(String(SendStr)) then
    begin
      Result := False;
      Exit;
    end;
    iRTime := GetTickCount;
    while Err and (GetTickCount < iRTime + 1000) do
    begin
      BackStr := Self.SimpleReadCard(Len);
      Err := False;
      if (BackStr = '') or (Len <> 3) then Err := True
      else if (BackStr[1] = #$1B) and (BackStr[2] = #$72) and
         (BackStr[3] = #$70) then Err := False;
      Application.ProcessMessages;
    end;
  end;
  if Self.FCancel then Self.ResetCard;
  Result := not Err;

end;

function TCardCommunicator.WriteCardWithOutVerify(s: String): Boolean;
var
  SendStr: array of Char;
  BackStr: String;
  Err: Boolean;
  i, j, ByteNum: Integer;
  iTime, Len, OldLen: DWord;
begin
  if not Self.ResetCard then
  begin
    Exit;
  end;

  i := Length(s);
  if (i = 0) or (i > MAXLENGTH) then
  begin
    Result := False;
    Exit;
  end;

  Len := i + 5;
  SetLength(SendStr, Len);
  SetLength(BackStr, Len);

  SendStr[0] := #$1B;
  SendStr[1] := #$74;
  for j := 1 to i do SendStr[j + 1] := s[j];
  SendStr[Len - 3] := #$1D;
  SendStr[Len - 2] := #$1B;
  SendStr[Len - 1] := #$5C;

  iTime := GetTickCount;
  Err := False;
  while ((not Err) and (not Self.FCancel)) or (GetTickCount < iTime + Self.FTimeOut * 1000) do
  begin
    Err := Self.SimpleWriteCard(String(SendStr));
    Application.ProcessMessages;
  end;
  Result := Err;
end;

end.

----------------------------------------------
-

作者：

blue_chun (blue)	★☆☆☆☆	-
	盒子活跃会员

2004/8/3 11:46:01

1楼：

Flyers
帮帮我呀~`

----------------------------------------------
-

信息

登陆以后才能回复