Moodsky 发表于 2007-2-8 10:27:07

mdb Utils (Access)

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.name,qa.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.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.name := db.QueryDefs.Name;
    result.sql := db.QueryDefs.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.name]) then
    begin
      if s<>'' then s := s +',';
      s := s +dstTdf.fields.Name;
    end;
    except
    end;
end;
if s<>'' then
    db.Execute(format(sqlstr,),DbSQLPassThrough);
end;

procedure renameMDbtable(db:database;srctbname,dstTbname:string);
var tdf:tabledef;
begin
tdf := db.TableDefs;
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;
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.fieldname,fldarray.fieldType,fldArray.fieldSize);
    fld.Set_Required(fldArray.Required);
    fld.Set_DefaultValue(fldArray.DefaultValue);
    tb.Fields.Append(fld);
end;
for i:=0 to high(idxArray) do
begin
    idx := tb.CreateIndex(idxArray.name);
    idx.Set_Primary(idxArray.primary );
    idx.Set_Unique(idxArray.unique);
    idx.Set_Required(idxArray.Required);
    for j:=0 to high(idxArray.fields) do
    begin
      fld := idx.CreateField(idxArray.fields.fieldname,idxArray.fields.fieldType,idxArray.fields.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.name,rs.table,rs.foreignTable,rs.Attributes);
    for j:= 0 to high(rs.fields) do
    begin
      fld := r.CreateField(rs.fields.fieldname,rs.fields.fieldType,rs.fields.fieldSize);
      fld.Set_ForeignName(rs.fields.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;
    result.name := r.name;
    result.table := r.table;
    tdf := db.TableDefs;
    result.foreignTable := r.ForeignTable;
    result.Attributes := r.Attributes;
    setlength(result.fields,r.Fields.Count);
    for j:=0 to r.fields.Count -1 do
    begin
      result.Fields.fieldname := r.fields.Name;
      fn := r.fields.Name;
      fld := tdf.Fields;
      result.fields.fieldSize := fld.Size;
      result.fields.fieldType := fld.Type_;
      try
      result.fields.foreignName := r.fields.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;
UntilEof(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.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 of Byte =
   ($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$13);
   xorArr2000: Array 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 := Chr(Ord(S1) xor XORArr97)
   else
   S1 := Chr(Ord(S1) xor XORArr2000);
If Access97 then
   result := s1
else
begin
    result := '';
    for i:=0 to length(s1) div 2 do
    begin
      result := result +widechar(ord(s1)+ord(s1)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:arrayof 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;
      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;
    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;
    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;
      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.
页: [1]
查看完整版本: mdb Utils (Access)