程序代码：Access.pas
unit GetAPass;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Variants, ComOBJ, StdCtrls, ExtCtrls, ComCtrls, FileCtrl, ActnList, ImgList,
ToolWin;
const
Model = 'yyyy-mm-dd hh:nn:ss';
type
PassType = record
PassCode: string;
FileType: string;
FileTime: TDateTime;
TimeWord: DWord;
TimeSecs: DWord;
TimeSite: string;
end;
TGetAForm = class(TForm)
ListView1: TListView;
ImageList1: TImageList;
StatusBar1: TStatusBar;
Memo1: TMemo;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton6: TToolButton;
ImageList2: TImageList;
Edit1: TEdit;
Pick1: TDateTimePicker;
Splitter1: TSplitter;
Button2: TButton;
ToolButton5: TToolButton;
ToolButton7: TToolButton;
ToolButton8: TToolButton;
ToolButton9: TToolButton;
ToolButton10: TToolButton;
procedure CloseForm(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure GetMDBDir(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure CreateMDB(Sender: TObject);
procedure GetAllPass(Sender: TObject);
procedure SetCurTime(Sender: TObject);
procedure Build9DBF(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
DateWord: DWord;
PassCode: WideString;
EncodeArray: array[0..19] of Word;
ReaderArray: array[0..19] of Word;
function Plus70(N: integer): DWord;
function ExecFile(FName: string): PassType;
procedure ExecDirectory(S: string);
function Make01(F: string; P: string = ''): boolean;
function Make02(F: string): boolean;
procedure SetTime(YY, MM, DD: Word); overload;
procedure SetTime(MYDate: TDate); overload;
public
{ Public declarations }
FileBox1: TFileListBox;
procedure CompressData(S, Pass: string);
end;
var
HH: Boolean;
//2079-06-05前 [EC37 9CFA 28E6 8A60 7B36 DFB1 1343 B133 795B 7C2A ]
//2079-06-05后 [ED37 9DFA 29E6 8B60 7A36 DEB1 1243 B033 785B 7D2A ]
{ 固定密钥 }
InhereCode: array[0..9] of Word =
($37EC, $FA9C, $E628, $608A, $367B, $B1DF, $4313, $33B1, $5B79, $2A7C);
{ 活动密钥 }
UserCode8: array[0..9] of Word = //89年9月17日前
($8B86, $345D, $2EC6, $C613, $E454, $02F5, $8477, $DFCF, $1134, $C592);
UserCode: array[0..9] of Word = //89年9月17日后
($7B86, $C45D, $DEC6, $3613, $1454, $F2F5, $7477, $2FCF, $E134, $3592);
InCode97: array[0..19] of byte = //Access 97 固定密钥
($86, $FB, $EC, $37, $5D, $44, $9C, $FA, $C6, $5E,
$28, $E6, $13, $00, $00, $00, $00, $00, $00, $00);
var
GetAForm: TGetAForm;
implementation
uses XEDUSER;
{$R *.DFM}
procedure TGetAForm.CompressData(S, Pass: string);
var
DAO: OLEVariant;
T: string;
P: string;
Path: string;
begin
Screen.Cursor := crHourGlass;
DAO := CreateOleObject('DAO.DBEngine.36');
Path := ExtractFilePath(S);
T := Path + 'TempFile.MDB';
if Pass = '' then P := '' else P := ';PWD=' + Pass;
try
DAO.CompactDatabase(S, T, '', 0, P);
//DAO.RepairDataBase(S); 修复数据库
DeleteFile(S);
RenameFile(T, S);
except
on E: Exception do begin
Screen.Cursor := crDefault;
raise;
end;
end;
Screen.Cursor := crDefault;
end;
procedure TGetAForm.SetTime(YY, MM, DD: Word);
var
myST: TSystemTime;
MSec: Word;
begin
with myST do begin
MyST.wYear := YY;
MyST.wMonth := MM;
MyST.wDay := DD;
DecodeTime(Time, wHour, wMinute, wSecond, MSec);
end;
try SetLocalTime(myST)except ShowMessage('Error'); end;
end;
procedure TGetAForm.SetTime(MYDate: TDate);
var
myST: TSystemTime;
MSec: Word;
begin
with myST do begin
DecodeDate(MyDate, wYear, wMonth, wDay);
DecodeTime(MyDate, wHour, wMinute, wSecond, MSec);
end;
try SetLocalTime(myST)except end;
end;
procedure TGetAForm.CreateMDB(Sender: TObject);
{var
Date0: TDate;
Date1: TDate;
Date2: TDate;
} begin
{ Date0 := EncodeDate(1978, 7, 01);
Date1 := EncodeDate(1989, 9, 17);
Date2 := EncodeDate(2079, 6, 05); }
Make01('D:/DB01.MDB', 'ABCDEFGHIJ');
Make01('D:/DB02.MDB', '加ACCE密码');
Make01('D:/DB03.MDB', '数据库密码');
end;
function TGetAForm.Plus70(N: integer): DWord;
begin
result := DWord(N shl 28);
end;
procedure SetFTime(const FileName: string; DTime: TDateTime);
var
Q: HFile;
ST: TSystemTime;
FT: TFileTime;
begin
DateTimeToSystemTime(DTime, ST);
SystemTimeToFileTime(ST, FT);
LocalFileTimeToFileTime(FT, FT);
Q := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
SetFileTime(Q, @FT, @FT, @FT);
end;
function TempPath(): string;
var
SPath, SFile: array[0..254] of char;
begin
GetTempPath(254, SPath);
GetTempFileName(SPath, '~SM', 0, SFile);
result := SFile;
DeleteFile(result);
end;
function TGetAForm.Make01(F: string; P: string = ''): boolean;
var
Linker: string;
Access: OleVariant;
begin
if FileExists(F) then DeleteFile(F);
Linker :=
'Provider=Microsoft.Jet.OLEDB.4.0;Data ' +
'Source=%s;Jet OLEDB
atabase Password=%s;';
Access := CreateOleObject('ADOX.Catalog');
Access.Create(Format(Linker, [F, P]));
end;
function TGetAForm.Make02(F: string): boolean;
var
Access: OleVariant;
begin
if FileExists(F) then DeleteFile(F);
Access := CreateOleObject('Access.Application');
Access.NewCurrentDatabase(F);
Access.Quit;
Access := null;
end;
procedure TGetAForm.FormCreate(Sender: TObject);
begin
Pick1.DateTime := Now;
FileBox1 := TFileListBox.Create(nil);
FileBox1.Visible := false;
FileBox1.Parent := Self;
FileBox1.Mask := '*.MDB';
end;
procedure TGetAForm.FormDestroy(Sender: TObject);
begin
FileBox1.Free;
end;
procedure TGetAForm.ExecDirectory(S: string);
var
i: integer;
P: PassType;
begin
Memo1.Lines.BeginUpdate;
FileBox1.Directory := S;
ListView1.Items.BeginUpdate;
ListView1.Items.Clear;
for i := FileBox1.Count - 1 downto 0 do begin
S := FileBox1.Items
;
P := ExecFile(S);
if P.PassCode = '' then Continue;
with ListView1.Items.Add do begin
Caption := S;
ImageIndex := 0;
SubItems.Add(P.FileType);
SubItems.Add(P.PassCode);
// SubItems.Add(FloatToStr(P.FileTime));
SubItems.Add(FormatDateTime(model, P.FileTime));
SubItems.Add(IntToHex(P.TimeWord, 8));
SubItems.Add(P.TimeSite);
SubItems.Add(IntToHex(P.TimeSecs, 8));
end;
end;
ListView1.Items.EndUpdate;
Memo1.Lines.EndUpdate;
end;
procedure TGetAForm.GetMDBDir(Sender: TObject);
var
S: string;
begin
if not SelectDirectory('选择数据库目录', '', S) then Exit;
Edit1.Text := S;
ExecDirectory(S);
end;
procedure TGetAForm.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if Key <> #13 then Exit;
if Trim(Edit1.Text) = '' then Exit;
ExecDirectory(Edit1.Text);
end;
procedure TGetAForm.CloseForm(Sender: TObject);
begin
Close;
end;
function TGetAForm.ExecFile(FName: string): PassType;
function CovTime(FD: _FileTime): TDateTime;
var
TCT: _SystemTime;
Tmp: _FileTime;
begin
FileTimeToLocalFileTime(FD, Tmp);
FileTimeToSystemTime(Tmp, TCT);
Result := SystemTimeToDateTime(TCT);
end;
var
Stream: TFileStream;
i, n: integer;
TP: TSearchRec;
WTime: TDateTime;
BTime: string;
WSec: longint;
M, S: string;
Buf: array[0..200] of byte;
Date0, Date1, Date2: TDatetime;
HB, HD: integer;
DeType: integer;
HX: DWord;
begin
FindFirst(FName, faAnyFile, TP);
// FT := CovTime(TP.FindData.ftCreationTime);
Stream := TFileStream.Create(FName, fmOpenReadWrite);
Stream.Seek($00, 00); Stream.Read(Buf[0], 200);
if Buf[$14] = 0 then begin
PassCode := '';
Stream.Seek($42, 00); Stream.Read(Buf[0], 20);
for i := 0 to 19 do
PassCode := PassCode + chr(Buf xor InCode97);
Result.PassCode := PassCode;
Result.FileType := 'ACCESS-97';
Result.FileTime := Now;
Exit; // 按Access97版本处理
end;
Stream.Seek($42, 00); Stream.Read(ReaderArray[0], 40);
Stream.Seek($75, 00); Stream.Read(DateWord, 4);
Stream.Free;
Result.TimeWord := DateWord;
for i := $42 to $42 + 5 do begin
if i = $72 then M := '-' else M := '';
S := S + #32 + M + IntToHex(Buf, 2);
end;
Delete(S, 1, 1);
DeType := 1;
if DeType = 1 then begin { 目前最新解码方法}
HB := DateWord and Plus70($F) shr 28;
HH := HB = 9; { 最后一步解码需要}
HD := 1 shl (HB xor 9 + 12); { 计算动态时间增量}
HX := Plus70(HB xor 1) + $3E6C94; { 密码串异或参考值}
WTime := (DateWord xor HX) / HD;
end;
if DeType = 2 then begin //以前的解码方法
Date0 := EncodeDate(1978, 7, 01);
//Date0 := $7000; //与上面一样
Date1 := $8000;
Date2 := $10000;
HH := False;
if (DateWord >= $90000000) and (DateWord < $B0000000) then begin
HH := True;
WSec := DateWord xor $903E6C94;
WTime := Date1 + WSec / $1000 + $8000;
Result.TimeSite := '1000';
end else begin
WSec := DateWord xor $803E6C94;
if WSec and $30000000 = 0 then begin
WTime := Date1 + WSec / $2000;
Result.TimeSite := '2000';
end else begin
WTime := Date1 + WSec / $4000 - $10000;
Result.TimeSite := '4000';
end;
end;
end;
Result.TimeSite := '****';
Result.TimeSecs := WSec;
BTime := '' + FormatDateTime('yyyy-mm-dd', WTime);
Memo1.Lines.Add(Format(
'创建时间：%10s，文件：%s，' +
'10进时间：%d，' +
'16进时间：%x，' +
'16进制OR：%x，%s' +
'密码串：%s',
[BTime, FName, DateWord, DateWord, DateWord xor $003E6C94, '', S]));
for i := 0 to 9 do begin
EncodeArray[i * 2] := Trunc(WTime) xor ($8000 xor UserCode);
EncodeArray[i * 2 + 1] := InhereCode xor integer(hh);
end;
PassCode := '';
for i := 0 to 19 do begin
N := EncodeArray xor ReaderArray;
if N <> 0 then PassCode := PassCode + WideChar(N);
end;
Result.FileType := 'ACCESS-2000';
Result.FileTime := WTime;
Result.PassCode := PassCode;
end;
procedure TGetAForm.GetAllPass(Sender: TObject);
begin
Screen.Cursor := crHourGlass;
Memo1.Clear;
if Trim(Edit1.Text) = '' then Exit;
ExecDirectory(Edit1.Text);
Screen.Cursor := crDefault;
end;
procedure TGetAForm.SetCurTime(Sender: TObject);
begin
Self.SetTime(Pick1.Date);
end;
procedure TGetAForm.Build9DBF(Sender: TObject);
var
I: integer;
D0: TDate;
Date0: TDateTime;
Date1: TDateTime;
Date2: TDateTime;
begin //批量建立数据库文件
Date0 := EncodeDate(1980, 1, 01);
Screen.Cursor := crHourGlass;
D0 := Date0 - 1;
for I := 1 to 200 do begin
//SetTime(D0 + I * 200);
SetTime(D0 + I * 200 + 0.11);
Make01(FormatFloat('D:/MineDir/DB0000"."MDB',
I), '汉字型密码' + Char(65 + Random(26)));
Application.ProcessMessages;
end;
Screen.Cursor := crDefault;
end;
procedure TGetAForm.Button2Click(Sender: TObject);
var
Date0: tdatetime;
M, N: integer;
begin
Date0 := EncodeDate(1978, 7, 01);
M := Trunc(Date0);
TellME(M);
N := $03E6C94;
TellME(inttohex(M, 4)); //就是Showmessage;
end;
end.