unit Unit1;
{
默认情况必须使用D2009之前的编译, 否则需要更改设置或者需要修改
程序使用Delphi 5编译!
SHA1 - written by Dave Barton (davebarton@bigfoot.com)
BASE32 - 没找到现成代码-_-!, 我偷懒写了一个能算key的
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, sha1;
type
TForm1 = class(TForm)
eSerial: TEdit;
eName: TEdit;
eCode: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
cbModify: TCheckBox;
cbAuto: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure eNameChange(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure cbModifyClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
Serial, vv: DWORD;
begin
GetVolumeInformationA('C:\', nil, 0, @Serial, vv, vv, nil, 0);
eSerial.Text := IntToHex(Serial, 8);
end;
const
TAB32: array[0..32 - 1] of Char = 'ABCDEFGHJKMNPQRSTVWXYZ1234567890';
BinTAB: array[0..1] of Char = '01';
function ByteToBin(AByte: Byte): String;
var
I: Integer;
begin
Result := '00000000';
for I := 8 downto 1 do
begin
Result[I] := BinTAB[AByte and 1];
AByte := AByte shr 1;
end;
end;
function BinToByte(Str: String): Byte;
var
I, Len: Integer;
begin
Result := 0;
Len := Length(Str);
for I := Len downto 1 do
begin
Result := (Result shl 1) or (Ord(Str[Len - I + 1]) - $30); //0,1
end;
end;
function MakeCode(Name: String; cSerial: DWORD): String;
var
Context: TSHA1Context;
Digest: TSHA1Digest;
Str: String;
I: Integer;
begin
Str := Name;
Str := Name + Char(cSerial and $FF)
+ Char((cSerial shr 8) and $FF)
+ Char((cSerial shr 16) and $FF)
+ Char((cSerial shr 24) and $FF)
+ 'Tencent';
SHA1Init(Context);
Context.Hash[0]:= $B1CAB1CA;
Context.Hash[1]:= $CCBFCCBF;
Context.Hash[2]:= $BFB2D6BE;
Context.Hash[3]:= $F8C7D8B5;
Context.Hash[4]:= $EEC7BCCD;
SHA1Update(Context, PAnsiChar(Str), Length(Str));
SHA1Final(Context, Digest);
//ABCDEFGHJKMNPQRSTVWXYZ1234567890
//160bits/5=32
Str := '';
for i := 0 to 20 - 1 do
begin
Str := Str + ByteToBin(Digest[i]);
end;
//
Result := '';
for i := 0 to 32 - 1 do
begin
Result := Result + Tab32[BinToByte(Copy(Str, i * 5 + 1, 5))];
if (((I + 1) mod 8) = 0) and (I <> 31) then
begin
Result := Result + '-';
end;
end;
end;
procedure TForm1.eNameChange(Sender: TObject);
var
Name: String;
begin
Name := eName.Text;
if (Length(Name) <= 0) or (Length(Name) > 32) then
begin
eCode.Text := 'Name must 1-32 char(s) at least!';
end
else
begin
eCode.Text := MakeCode(Name, StrToIntDef('$' + Trim(eSerial.Text), 0));
if cbAuto.Checked then
begin
eCode.SelectAll;
eCode.CopyToClipboard;
end;
end;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
eNameChange(eName);
end;
procedure TForm1.cbModifyClick(Sender: TObject);
begin
eSerial.Enabled := cbModify.Checked;
eSerial.ReadOnly := not cbModify.Checked;
if not cbModify.Checked then
begin
FormCreate(Self);
end;
end;
end.
