unit mdbUtils;
interface
uses windows,classes,sysutils,dao2000,dao97, comobj,adodb{$ifdef ver140},variants{$endif},dialogs;
type
TFieldRec=record
fieldname:string;
fieldType,fieldSize:integer;
Required:boolean;
DefaultValue:olevariant;
ForeignName:string;
end;
TFieldRecArray=Array of TFieldRec;
TrelationRec=record
name,table,foreignTable:string;
Attributes:integer;
fields:TfieldRecArray;
end;
TRelationArray=array of TrelationRec;
TindexRec=record
name:string;
primary,unique,Required:boolean;
fields:TfieldRecArray;
end;
TIndexRecArray=array of TIndexRec;
TParamRec=record
value :olevariant;
type_:smallint;
Direction:smallint;
name : widestring;
end;
TparamRecArray=array of TparamRec;
TqueryDef=record
name:string;
sql:string;
end;
TqueryDefArray=array of TqueryDef;
function GetWinTempFile:string;
procedure CompactMdbDatabase(srcDbname,dstDbname,oldpwd,newpwd:string;bAccess97:boolean=true);
procedure CompactMdbDatabaseX(Dbname:string);
procedure changeMdbPwd(dbname,oldpwd,newpwd:string;bAccess97:boolean=true);
procedure clearLinkTables(dbname,pwd:string);
procedure connectx(srcName, srcPwd, dstName, dstPwd,suffix: String);
function GetMDBPassWord(filename:string):string;
function ConnectAdo(adoconnection:TadoConnection;dbName,pwd:string):boolean;
function CreateMdb(dbname,pwd:string):boolean;
function isAccess97(dbname:string):boolean;
function OpenDatabase(dbname,pwd:string):database;
//relations
function GetRelations(dbname,pwd:string):TrelationArray;
procedure ClearRelations(dbname,pwd:string);
procedure CreateRelations(dbname,pwd:string;rs:TrelationArray);
//recordset
function createMDBTable(db:database;tbname:string;fldArray:TFieldRecArray;IdxArray:TIndexRecArray):tableDef;
procedure AlterMdbTable(db:database;tbname:string;fldArray:TfieldRecArray;IdxArray:TindexRecArray);
//function compareMdbTable(srcdb,dstdb:database;tbname:string;var outstr:string):boolean;
procedure renameMDBtable(db:database;srctbname,dstTbname:string);
procedure copyMdbTable(db:database;srcTdf,dstTdf:TableDef);
procedure dropmdbTable(db:database;tbname:string);
//querydefs
function getQuerydefs(dbname,pwd:string):TquerydefArray;
function clearQuerydefs(db:database):boolean;
function createQueryDef(db:database;qdf:TqueryDef):queryDef;
function createQueryDefs(db:database;qa:TquerydefArray):boolean;
implementation
function createQueryDefs(db:database;qa:TquerydefArray):boolean;
var i:integer;
begin
result := false;
for i:=0 to high(qa) do
begin
db.createQueryDef(qa[i].name,qa[i].sql);
end;
result := true;
end;
function createQueryDef(db:database;qdf:TqueryDef):queryDef;
var i:integer;
begin
result := nil;
result := db.CreateQueryDef(qdf.name,qdf.sql);
end;
function clearQuerydefs(db:database):boolean;
var i:integer;
begin
for i:= db.QueryDefs.count -1 downto 0 do
begin
db.querydefs.Delete(db.querydefs[i].Name);
end;
db.QueryDefs.Refresh;
end;
function getQuerydefs(dbname,pwd:string):TquerydefArray;
var db:database;
i,j:integer;
begin
db := opendatabase(dbname,pwd);
setlength(result,db.querydefs.count);
for i:=0 to db.QueryDefs.count-1 do
begin
result[i].name := db.QueryDefs[i].Name;
result[i].sql := db.QueryDefs[i].sql;
end;
end;
procedure dropmdbTable(db:database;tbname:string);
begin
db.TableDefs.Delete(tbname);
db.TableDefs.Refresh;
end;
procedure copyMdbTable(db:database;srcTdf,dstTdf:TableDef);
const
sqlstr='insert into %s select %s from %s';
var s:string;
i:integer;
begin
s := '';
for i:=0 to dstTdf.Fields.Count -1 do
begin
try
if assigned(srcTdf.fields[dstTdf.fields[i].name]) then
begin
if s<>'' then s := s +',';
s := s +dstTdf.fields[i].Name;
end;
except
end;
end;
if s<>'' then
db.Execute(format(sqlstr,[dsttdf.name,s,srctdf.name]),DbSQLPassThrough);
end;
procedure renameMDbtable(db:database;srctbname,dstTbname:string);
var tdf:tabledef;
begin
tdf := db.TableDefs[srctbname];
if assigned(tdf) then
begin
tdf.Set_Name(dstTbname);
db.TableDefs.Refresh;
end;
end;
procedure AlterMdbTable(db:database;tbname:string;fldArray:TfieldRecArray;IdxArray:TindexRecArray);
var
tdfold,tdfnew:tabledef;
fld:field;
idx : _index;
i ,j : integer;
bfound:boolean;
begin
tdfold := db.TableDefs[tbname];
if not assigned(tdfold) then exit;
tdfnew := createmdbTable(db,'temp2002xh',fldArray,idxArray);
copymdbTable(db,tdfold,tdfnew);
dropmdbTable(db,tbname);
renameMdbTable(db,'temp2002xh',tbname);
end;
function createMDBTable(db:database;tbname:string;fldArray:TFieldRecArray;IdxArray:TIndexRecArray):tableDef;
var
tb : tabledef;
fld : field;
idx : _index;
i ,j : integer;
begin
tb := db.CreateTableDef(tbname,0,'','');
for i:=0 to high(fldArray) do
begin
fld := tb.CreateField(fldarray[i].fieldname,fldarray[i].fieldType,fldArray[i].fieldSize);
fld.Set_Required(fldArray[i].Required);
fld.Set_DefaultValue(fldArray[i].DefaultValue);
tb.Fields.Append(fld);
end;
for i:=0 to high(idxArray) do
begin
idx := tb.CreateIndex(idxArray[i].name);
idx.Set_Primary(idxArray[i].primary );
idx.Set_Unique(idxArray[i].unique);
idx.Set_Required(idxArray[i].Required);
for j:=0 to high(idxArray[i].fields) do
begin
fld := idx.CreateField(idxArray[i].fields[j].fieldname,idxArray[i].fields[j].fieldType,idxArray[i].fields[j].fieldSize);
idx.Fields.append(fld);
end;
tb.Indexes.Append(idx);
end;
db.TableDefs.Append(tb);
result := tb;
end;
procedure CompactMdbDatabaseX(Dbname:string);
var pwd:string;
tmpdb:string;
begin
pwd := getMdbPassword(dbname);
tmpdb := getWinTempfile;
tmpDb := changefileExt(tmpdb,'.mdb');
compactMdbDatabase(dbname,tmpdb,pwd,'',isAccess97(dbname));
if fileExists(tmpdb) then
begin
copyfile(pchar(tmpdb),pchar(dbname),false);
deletefile(tmpdb);
end;
end;
procedure CreateRelations(dbname,pwd:string;rs:TrelationArray);
var db:database;
i,j : integer;
fld:field;
r:relation;
begin
db := opendatabase(dbname,pwd);
for i:= 0 to high(rs) do
begin
r := db.CreateRelation(rs[i].name,rs[i].table,rs[i].foreignTable,rs[i].Attributes);
for j:= 0 to high(rs[i].fields) do
begin
fld := r.CreateField(rs[i].fields[j].fieldname,rs[i].fields[j].fieldType,rs[i].fields[j].fieldSize);
fld.Set_ForeignName(rs[i].fields[j].foreignName);
r.Fields.Append(fld);
end;
db.Relations.Append(r);
end;
end;
function OpenDatabase(dbname,pwd:string):database;
var db:database;
dbEngine:_dbengine;
begin
if pwd <>'' then
pwd := ';pwd='+pwd;
if isAccess97(dbname) then
begin
dbengine := CreateComObject(dao97.CLASS_DBEngine) as _DBEngine;
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,pwd);
end else
begin
dbengine := CreateComObject(dao2000.CLASS_DBEngine) as _DBEngine;
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,pwd)
end;
result := db;
end;
function GetRelations(dbname,pwd:string):TrelationArray;
var db:database;
i,j:integer;
r:relation;
tdf:tabledef;
fn:string;
fld:field;
begin
db := opendatabase(dbname,pwd);
setlength(result,db.Relations.Count);
for i:=0 to db.Relations.Count -1 do
begin
r :=db.Relations[i];
result[i].name := r.name;
result[i].table := r.table;
tdf := db.TableDefs[r.table];
result[i].foreignTable := r.ForeignTable;
result[i].Attributes := r.Attributes;
setlength(result[i].fields,r.Fields.Count);
for j:=0 to r.fields.Count -1 do
begin
result[i].Fields[j].fieldname := r.fields[j].Name;
fn := r.fields[j].Name;
fld := tdf.Fields[fn];
result[i].fields[j].fieldSize := fld.Size;
result[i].fields[j].fieldType := fld.Type_;
try
result[i].fields[j].foreignName := r.fields[j].ForeignName;
except
showmessage('error');
end;
end;
end;
end;
function isAccess97(dbname:string):boolean;
var fi:file of byte;
i:integer;
by:byte;
begin
AssignFile(FI,dbname);
Reset(FI);
result := false;
// Read file
I := 0;
Repeat
If not Eof(FI) then
Begin
Read(FI,By);
Inc(I);
if I=$15 then
begin
result := by<>1;
break;
end;
End;
Until Eof(FI);
closefile(fi);
end;
procedure ClearRelations(dbname,pwd:string);
var db:database;
dbEngine:_dbengine;
tempname:string;
i:integer;
begin
if pwd <>'' then
pwd := ';pwd='+pwd;
if isAccess97(dbname) then
begin
dbengine := CreateComObject(dao97.CLASS_DBEngine) as _DBEngine;
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,pwd);
end else
begin
dbengine := CreateComObject(dao2000.CLASS_DBEngine) as _DBEngine;
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,pwd)
end;
for i:=db.Relations.Count -1 downto 0 do
db.Relations.Delete(db.Relations.Item[i].Name);
end;
function CreateMdb(dbname,pwd:string):boolean;
var dbengine:_dbEngine;
begin
result := true;
try
dbengine := CreateComObject(CLASS_DBEngine) as _DBEngine;
dbengine.CreateDatabase(dbname,';pwd='+pwd,dbVersion30);
except
result := false;
end;
end;
function ConnectAdo(adoconnection:TadoConnection;dbName,pwd:string):boolean;
var s:string;
begin
result := false;
s:='Provider=Microsoft.Jet.OLEDB.4.0;';
s:=s+'User ID=Admin;';
s:=s+'Data Source='+dbName+';';
s:=s+'Mode=Share Deny None;';
s:=s+'Jet OLEDB:Database Password="'+pwd+'";';
try
adoconnection.connected := false;
adoconnection.connectionstring := s;
adoconnection.connected := true;
except
end;
result := adoConnection.connected;
end;
function GetMDBPassWord(filename:string):string;
Const
XorArr97 : Array[0..12] of Byte =
($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$13);
xorArr2000: Array[0..28] of Byte =
($A2,$69,$EC,$37,$79,$D6,$9C,$FA,$E2,$CC,$28,$E6,$37,$24,$8A,$60,$70,$06,$7B,$36,$D1,$E0,$DF,$B1,$53,$66,$13,$43,$EB);
Var
I : Integer;
S1 : String;
FI : File of Byte;
By : Byte;
Access97 : Boolean;
FileError : Boolean;
count : integer;
Begin
result := '';
// Init
FileError := False;
Access97 := True;
// Open *.mbd file
AssignFile(FI,Filename);
Reset(FI);
// Read file
I := 0;
Repeat
If not Eof(FI) then
Begin
Read(FI,By);
Inc(I);
if I=$15 then
access97 := by<>1;
End;
Until (I = $42) or Eof(FI);
If Eof(FI) then
raise exception.create('无效的数据库文件');
// Read password string
S1 := '';
if Access97 then count := 12
else count := 28;
For I := 0 to count do
If not Eof(FI) then
Begin
Read(FI,By);
S1 := S1 + Chr(By);
End;
If Eof(FI) then
raise exception.create('无效的数据库文件');
//Close file
CloseFile(FI);
// Decode string
For I := 0 to count do
if access97 then
S1[I + 1] := Chr(Ord(S1[I + 1]) xor XORArr97[I])
else
S1[I + 1] := Chr(Ord(S1[I + 1]) xor XORArr2000[I]);
If Access97 then
result := s1
else
begin
result := '';
for i:=0 to length(s1) div 2 do
begin
result := result +widechar(ord(s1[i*2+1])+ord(s1[i*2+2])shl 8);
end;
end;
End;
//note: srcdbname and dstdbname cann't be the same
procedure CompactMdbDatabase(srcDbname,dstDbname,oldpwd,newpwd:string;bAccess97:boolean=true);
var idbEngine:_dbEngine;
begin
if oldpwd <>'' then oldpwd := ';pwd='+oldpwd;
if newpwd <>'' then newpwd := ';pwd='+newpwd;
if bAccess97 then
begin
idbengine := CreateComObject(dao97.CLASS_DBEngine) as _DBEngine;
idbEngine.CompactDatabase(srcDbname,dstDbname,newpwd,dbVersion30,oldpwd);
end else
begin
idbengine := CreateComObject(dao2000.CLASS_DBEngine) as _DBEngine;
idbEngine.CompactDatabase(srcDbname,dstDbname,newpwd,dbVersion40,oldpwd);
end;
end;
function GetWinTempFile:string;
var fn,pn:array[0..MAX_Path-1]of char;
begin
getTempPath(MAX_PATH,pn);
gettempfilename(pn,'TEMP',999,fn);
result := fn;
end;
//note try to clear access2000 database's pwd may raise an error
procedure changeMdbPwd(dbname,oldpwd,newpwd:string;bAccess97:boolean=true);
var db:database;
dbEngine:_dbengine;
tempname:string;
begin
if bAccess97 then
begin
dbengine := CreateComObject(dao97.CLASS_DBEngine) as _DBEngine;
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,';pwd='+oldpwd);
db.NewPassword(oldpwd,widestring(newpwd));
db.Close;
end else
begin
if (newpwd<>'') and (oldpwd <>'')then
begin
dbengine := CreateComObject(dao2000.CLASS_DBEngine) as _DBEngine;
if oldpwd <>'' then
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,';pwd='+oldpwd)
else
db := dbengine.OpenDatabase(dbname,dbDriverNoPrompt,false,'');
db.NewPassword(oldpwd,widestring(newpwd));
db.Close;
end else
begin
tempname := changefileext(getwintempfile,'.mdb');
compactmdbDatabase(dbname,tempname,oldpwd,newpwd,false);
copyfile(pchar(tempname),pchar(dbname),false);
deletefile(tempname);
end;
end;
end;
procedure clearLinkTables(dbname,pwd:string);
var engine : _dbengine;
dbs:database;
i:Integer;
tdtest,tdfloop:TableDef;
strtb,strConnect :string;
tdfLinked:tableDef;
begin
engine := createcomobject(CLASS_DBEngine) as _dbengine;
dbs := engine.OpenDatabase(dbname,dbDriverNoPrompt,false,';name=dbs;pwd='+pwd);
for i := dbs.TableDefs.Count-1 downto 0 do
begin
tdfloop := dbs.TableDefs.Item[i];
If ((tdfloop.Attributes And dbAttachedTable) <> 0) Or
((tdfloop.Attributes And dbAttachExclusive) <> 0) Or
((tdfloop.Attributes And dbAttachSavePWD) <> 0) Then
dbs.TableDefs.Delete(tdfloop.Name)
end;
end;
//link tables between databases
procedure connectx(srcName, srcPwd, dstName, dstPwd,suffix: String);
var engine : _dbengine;
dbsSrc, dbsDst:database;
i,j:Integer;
tdtest,tdfloop:TableDef;
strtb,strConnect :string;
tdfLinked:tableDef;
begin
engine := createcomobject(CLASS_DBEngine) as _dbengine;
dbssrc := engine.OpenDatabase(srcname,dbDriverNoPrompt,false,';name=dbsrc;pwd='+srcpwd);
dbsDst := engine.OpenDatabase(dstname,dbDriverNoPrompt,false,';name=dbdst;pwd='+dstpwd);
for i := dbsDst.TableDefs.Count-1 downto 0 do
begin
tdfloop := dbsDst.TableDefs.Item[i];
If ((tdfloop.Attributes And dbAttachedTable) <> 0) Or
((tdfloop.Attributes And dbAttachExclusive) <> 0) Or
((tdfloop.Attributes And dbAttachSavePWD) <> 0) Then
dbsDst.TableDefs.Delete(tdfloop.Name)
end;
for i:=0 to dbsSrc.TableDefs.count-1 do
begin
tdfloop := dbsSrc.tabledefs[i];
If (tdfloop.Attributes And dbSystemObject) = 0 Then
begin
strtb := tdfloop.Name;
for j:=0 to dbsDst.tabledefs.count-1 do
begin
tdTest := dbsDst.tableDefs.item[j];
If tdTest.Name = strtb Then
begin
If Not (
((tdTest.Attributes and dbAttachedTable) <> 0) Or
((tdTest.Attributes And dbAttachExclusive) <> 0) Or
((tdTest.Attributes And dbAttachSavePWD) <> 0)) Then
strtb := strtb + suffix
Else
begin
dbsDst.TableDefs.Delete( strtb);
end;
end;
end;
strConnect := ';DATABASE='+ srcName + ';pwd=' + srcPwd;
tdfLinked := dbsDst.CreateTableDef(strtb,0,tdfLoop.name, strConnect);
dbsDst.TableDefs.Append(tdfLinked);
end;
end;
end;
end.
