ฝาก delphi mdbUtils.pas แก้ปัญหา ms access

[doramon]

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[dstTdf.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,[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.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[j].fieldname,idxArray.fields[j].fieldType,idxArray.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.name,rs.table,rs.foreignTable,rs.Attributes);
    for j:= 0 to high(rs.fields) do
    begin
      fld := r.CreateField(rs.fields[j].fieldname,rs.fields[j].fieldType,rs.fields[j].fieldSize);
      fld.Set_ForeignName(rs.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;
    result.name := r.name;
    result.table := r.table;
    tdf := db.TableDefs[r.table];
    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[j].fieldname := r.fields[j].Name;
      fn := r.fields[j].Name;
      fld := tdf.Fields[fn];
      result.fields[j].fieldSize := fld.Size;
      result.fields[j].fieldType := fld.Type_;
      try
      result.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.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)
     else
     S1[I + 1] := Chr(Ord(S1[I + 1]) 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[i*2+1])+ord(s1[i*2+2])shl ;
    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;
      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[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.