ado_access.pas

医院X光片资料管理系统—全部源码 这是源码。去年做的一个小软件。因为这是给一家医院做的

{========================================}
{Unit name: ADO_Access.pas               }
{Last modified: 2001.5.13                }
{Suit for: Delphi 5                      }
{Purpose: Create/Compact/Repair MDB      }
{Bug list:                               }
{  1. Can't support encrypt              }
{----------------------------------------}
{       Written by Micro Whaight         }
{========================================}
unit ADO_Access;

interface
uses
  SysUtils, Forms, FileCtrl, Windows, Classes,
  ComObj, JRO_TLB;

function CreateMDB(const MDBName: string; const PWD: string = '';
  const MDBType: string = '97'): Boolean;
function CompactRepairMDB(const MDBName: string; const OldPWD: string = '';
  const NewPWD: string = ''; const MDBType: string = '97'): Boolean;
function GetTempFile: string;
function DecryptAccess(const MDBFile: string): Boolean;
function EncryptAccess: Boolean;

implementation
var
  OldByte: Integer;
  sFile: string;

function CreateMDB(const MDBName: string; const PWD: string = '';
  const MDBType: string = '97'): Boolean;
var
  ADOVar: OleVariant;
  sCreateString: string;
begin
  Result := False;
  //Check file and path exist
  if FileExists(MDBName) then
  begin
    raise Exception.Create(MDBName + '已经存在!');
    Exit;
  end;
  if not DirectoryExists(ExtractFilePath(MDBName)) then
  begin
    raise Exception.Create('文件路径:' + #13 + ExtractFilePath(MDBName) + #13
      + '不存在!');
    Exit;
  end;
  //Set create string
  sCreateString := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
  sCreateString := sCreateString + MDBName + ';';
  if MDBType = '97' then
    sCreateString := sCreateString + 'Jet OLEDB:Engine Type=4'
  else if MDBType = '2000' then
    sCreateString := sCreateString + 'Jet OLEDB:Engine Type=5'
  else begin
    raise Exception.Create('本函数不支持建立其他格式的MS Access数据库!');
    Exit;
  end;
  if PWD <> '' then
    sCreateString := sCreateString + ';Jet OLEDB:Database Password=' + PWD;
  //Create ADOX object
  try
    ADOVar := CreateOleObject('ADOX.Catalog');
    ADOVar.Create(sCreateString);
    Result := True;
  except
    raise Exception.Create('无法新建 MS Access ' + MDBType + ' 数据库:' + #13
      + MDBName);
  end;
end;

function CompactRepairMDB(const MDBName: string; const OldPWD: string = '';
  const NewPWD: string = ''; const MDBType: string = '97'): Boolean;
var
  MyJetEngine: JetEngine;
  sTempFile, sOldJRO, sNewJRO: string;
begin
  Result := False;
  //Check file exist.
  if not FileExists(MDBName) then
  begin
    raise Exception.Create('MS Access数据库:' + #13 + MDBName + #13
      + '不存在!');
    Exit;
  end;
  //Set environment
  sTempFile := GetTempFile;
  sOldJRO := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + MDBName;
  sNewJRO := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + sTempFile;
  if MDBType = '97' then
  begin
    sOldJRO := sOldJRO + ';Jet OLEDB:Engine Type=4';
    sNewJRO := sNewJRO + ';Jet OLEDB:Engine Type=4';
  end
  else if MDBType = '2000' then begin
    sOldJRO := sOldJRO + ';Jet OLEDB:Engine Type=5';
    sNewJRO := sNewJRO + ';Jet OLEDB:Engine Type=5';
  end
  else begin
    raise Exception.Create('本函数不支持建立其他格式的MS Access数据库!');
    Exit;
  end;
  if OldPWD <> '' then
    sOldJRO := sOldJRO + ';Jet OLEDB:Database Password=' + OldPWD;
  if NewPWD <> '' then
    sNewJRO := sNewJRO + ';Jet OLEDB:Database Password=' + NewPWD;
  //Compact
  try
    try
      MyJetEngine := CoJetEngine.Create();
      MyJetEngine.CompactDatabase(sOldJRO, sNewJRO);
      Result := True;
    except
      raise Exception.Create('无法修复和压缩MS Access ' + MDBType + ' 数据库:'
        + #13 + MDBName);
    end;
  finally
    MyJetEngine := nil;
  end;
  //Rename file.
  if not Result then
    Exit;
  //Copy File
  if not CopyFile(PChar(sTempFile), PChar(MDBName), False) then
  begin
    raise Exception.Create('无法复制文件!');
    Result := False;
    Exit;
  end;
  //Delete temp file.
  if not DeleteFile(PChar(sTempFile)) then
  begin
    raise Exception.Create('无法删除临时文件!');
    Result := False;
    Exit;
  end;

  Result := True;
end;

function GetTempFile: string;
var
  caTempPath, caTempFile: array[0..Max_Path] of Char;
begin
  Result := '';
  GetTempPath(255, @caTempPath);
  GetTempFileName(@caTempPath, '', 0, @caTempFile);
  //Delete temp file
  DeleteFile(@caTempFile);

  Result := StrPas(caTempFile);
end;

function DecryptAccess(const MDBFile: string): Boolean;
var
  fsDecrypt: TFileStream;
  ClearByte: Integer;
begin
  Result := False;
  sFile := MDBFile;
  if not FileExists(sFile) then
    Exit;
  ClearByte := $86;
  try
    fsDecrypt := TFileStream.Create(MDBFile, fmOpenReadWrite);
  except
    Exit;
  end;
  with fsDecrypt do
  try
    Seek($42, soFromBeginning);
    Read(OldByte, 1);
    Seek($42, soFromBeginning);
    Write(ClearByte, 1);
    Result := True;
  finally
    Free;
  end;
end;

function EncryptAccess: Boolean;
var
  fsEncrypt: TFileStream;
begin
  Result := False;
  if sFile = '' then
    Exit;
  try
    fsEncrypt := TFileStream.Create(sFile, fmOpenWrite);
  except
    Exit;
  end;
  with fsEncrypt do
  try
    Seek($42, soFromBeginning);
    Write(OldByte, 1);
    Result := True;
  finally
    Free;
  end;
end;

end.