Talk:FireDAC.Phys.MSAcc.TFDMSAccessService

About create a secure database:

When creating database necessarily use CREATE_DBV4 instead CREATE_DB, because CREATE_DB created database in newest 2007 format, which not supported secure.

Helper unit for work with secure database (create, compact), this draft version:

unit ComTpsDB.MSAccService;

interface

uses FireDAC.Phys.MSAcc, FireDAC.Stan.Def;

{$DEFINE FireDAC_Monitor}

type
  TFDMSAccessServiceHelper=class helper for TFDMSAccessService
  private
    function GetAction: TFDMSAccessAction;
  public
    property Action: TFDMSAccessAction read GetAction;
  end;

  TFDMSAccessServiceNew=class(TFDMSAccessService)
  private
    FNeedSystemDB:boolean;
    FSystemDB:string;
    FUserName:string;
    FUserPass:string;
  protected
    procedure InternalExecute; override;
  public
    property NeedSystemDB:boolean read FNeedSystemDB write FNeedSystemDB;
    property SystemDB:string read FSystemDB write FSystemDB;
    property UserName:string read FUserName write FUserName;
    property UserPass:string read FUserPass write FUserPass;
  end;

implementation

uses FireDAC.Stan.Util, FireDAC.Phys.ODBCCli, System.SysUtils, FireDAC.Stan.Error,
     FireDAC.Stan.Consts, System.Win.ComObj, Winapi.Windows, System.Variants,
     FireDAC.Phys.ODBCBase, System.IOUtils, FireDAC.Comp.Client;

{ TFDMSAccessServiceHelper }

function TFDMSAccessServiceHelper.GetAction: TFDMSAccessAction;
begin
  result:=Self.FAction;
end;

{ TFDMSAccessServiceNew }

procedure TFDMSAccessServiceNew.InternalExecute;
var
  DoInherited:boolean;
  sStr, sDrv, sDb: String;
  lLastDrv, lSort:boolean;
  aFDConnection:TFDConnection;

  function NormFileName(AName: String): String;
  begin
    Result := FDExpandStr(AName);
    if (Pos(' ', Result) > 0) and (Result[1] <> '"') then
      Result := '"' + Result + '"';
  end;

  procedure DeleteDatabase(const AName: String);
  var
    sFile: String;
  begin
    sFile := FDExpandStr(AName);
    System.SysUtils.DeleteFile(sFile);
    System.SysUtils.DeleteFile(ChangeFileExt(sFile, '.ldb'));
    System.SysUtils.DeleteFile(ChangeFileExt(sFile, '.laccdb'));
  end;

  {$IFDEF MSWINDOWS}
  function RenameDatabase(const AOldName, ANewName: String): Boolean;
  var
    sOldFile, sNewFile, sLdbFile: String;
  begin
    sOldFile := FDExpandStr(AOldName);
    sNewFile := FDExpandStr(ANewName);
    Result := RenameFile(sOldFile, sNewFile);
    if Result then begin
      sLdbFile := ChangeFileExt(sOldFile, '.ldb');
      if FileExists(sLdbFile) then
        RenameFile(sLdbFile, ChangeFileExt(sNewFile, '.ldb'));
      sLdbFile := ChangeFileExt(sOldFile, '.laccdb');
      if FileExists(sLdbFile) then
        RenameFile(sLdbFile, ChangeFileExt(sNewFile, '.laccdb'));
    end;
  end;

  function GenTempFileName(const AName: String): String;
  var
    sPath: String;
  begin
    sPath := ExtractFilePath(FDExpandStr(AName));
    SetLength(Result, MAX_PATH);
    GetTempFileName(PChar(sPath), 'FD', 0, PChar(Result));
    Result := PChar(Result);
  end;

  procedure ProcessOLEException(AExc: EOleSysError);
  var
    sMsg: String;
    iCode: Integer;
    oExc: EFDDBEngineException;
    oErr: TFDDBError;
  begin
    sMsg := AExc.Message;
    iCode := er_FD_AccUnknownOleError;
    if AExc is EOLEException then begin
      if Pos('Class not registered', sMsg) > 0 then
        iCode := er_FD_AccClassNotRegistered
      else if Pos('Unrecognized database format', sMsg) > 0 then
        iCode := er_FD_AccUnrecognizedDbFormat
      else if Pos('Not a valid password', sMsg) > 0 then
        iCode := er_FD_AccNotValidPassword;
    end
    else
      if Pos('Class not registered', sMsg) > 0 then
        iCode := er_FD_AccSysClassNotRegistered;

    oExc := FDDBEngineExceptionCreate(EMSAccessNativeException, iCode, []);
    oErr := TFDDBError.Create;
    oErr.Message := sMsg;
    oExc.Append(oErr);
    FDException(Self, oExc{$IFDEF FireDAC_Monitor}, False{$ENDIF});
  end;

  procedure CompactRepair;
  // https://msdn.microsoft.com/uk-ua/bb237197(v=office.12).aspx
  var
    vJro: Variant;
    sSource, sDest, sProvider, sDestDatabase: String;
    iEngine: Integer;
    lRename: Boolean;
  begin
    if not FileExists(Database) then
      FDException(Self, FDDBEngineExceptionCreate(EMSAccessNativeException,
        er_FD_AccDbNotExists, [Database]) {$IFDEF FireDAC_Monitor}, False{$ENDIF});
    try
      vJro := CreateOLEObject('JRO.JetEngine');
      try
        lRename := (DestDatabase = '') or (DestDatabase = Database);
        if lRename then
          sDestDatabase := GenTempFileName(Database)
        else
          sDestDatabase := DestDatabase;
        DeleteDatabase(sDestDatabase);
        sSource := 'Provider=%s;Data Source=%s;Jet OLEDB:Engine Type=%d';
        sDest := sSource;
        if Password <> '' then begin
          sSource := sSource + ';Jet OLEDB:Database Password=' + Password;
          if not ResetPassword then
            sDest := sSource;
        end;
        if lSort then
          sDest := sDest + ';LocaleIdentifier=' + SortOrder;
        if Encrypted then
          sDest := sDest + ';Jet OLEDB:Encrypt Database=True';
        iEngine := 5;
        case DBVersion of
        avDefault:
          begin
            if sDrv = 'Microsoft Access Driver (*.mdb, *.accdb)' then
              sProvider := 'Microsoft.ACE.OLEDB.12.0'
            else
              sProvider := 'Microsoft.Jet.OLEDB.4.0';
          end;
        avAccess2:
          begin
            sProvider := 'Microsoft.Jet.OLEDB.4.0';
            iEngine := 3;
          end;
        avAccess95,
        avAccess97:
          begin
            sProvider := 'Microsoft.Jet.OLEDB.4.0';
            iEngine := 4;
          end;
        avAccess2000,
        avAccess2003:
          begin
            sProvider := 'Microsoft.Jet.OLEDB.4.0';
            iEngine := 5;
          end;
        avAccess2007:
          begin
            sProvider := 'Microsoft.ACE.OLEDB.12.0';
            iEngine := 5;
          end;
        end;
        //
        if FSystemDB<>'' then sSource := sSource + ';Jet OLEDB:System Database=' + FSystemDB;
        if FUserName<>'' then sSource := sSource + ';User Id=' + FUserName;
        if FUserPass<>'' then sSource := sSource + ';Password=' + FUserPass;
        //
        vJro.CompactDatabase(Format(sSource, [sProvider, FDExpandStr(Database),
          iEngine]), Format(sDest, [sProvider, FDExpandStr(sDestDatabase), iEngine]));
        if lRename then begin
          DeleteDatabase(Database);
          if RenameDatabase(sDestDatabase, Database) then
            DeleteDatabase(sDestDatabase);
        end;
      finally
        vJro := Unassigned;
      end;
    except
      on E: EOleSysError do
        ProcessOLEException(EOleSysError(E))
    end;
  end;
  {$ENDIF}

  function GeneratePID:string;
  var
    g1:TGUID;
  begin
    CreateGUID(g1);
    result:=g1.ToString;
    result:=result.Replace('{','');
    result:=result.Replace('}','');
    result:=result.Replace('-','');
    if result.Length>20 then result:=result.Substring(0,20);
  end;

begin
  sDrv := (DriverLink.DriverIntf as IFDPhysODBCDriver).ODBCDriver;
  DoInherited:=true;
  case Action of
  aaCompactDB:
{$IFDEF MSWINDOWS}
    begin
      DoInherited:=false;
      //
      CompactRepair;
    end;
{$ELSE}
    begin
      DoInherited:=false;
      //
      sDb := NormFileName(Database);
      sStr := 'COMPACT_DB=' + sDb + ' ';
      if DestDatabase = '' then
        sStr := sStr + sDb
      else
        sStr := sStr + NormFileName(DestDatabase);
      if SortOrder <> '' then
        sStr := sStr + ' ' + SortOrder;
      ExecuteBase(ODBC_ADD_DSN, sDrv, sStr);
    end;
{$ENDIF}
  aaRepairDB:
{$IFDEF MSWINDOWS}
  begin
    DoInherited:=false;
    //
    CompactRepair;
  end;
{$ELSE}
    begin
      DoInherited:=false;
      //
      sStr := 'REPAIR_DB=' + NormFileName(Database);
      ExecuteBase(ODBC_ADD_DSN, sDrv, sStr);
    end;
{$ENDIF}
    aaCreateDB:begin
      if FNeedSystemDB then
      begin
        DoInherited:=false;
        // http://www.litwindow.com/Knowhow/HowTo/howto_create_secure_access_dat.html
        // http://stackoverflow.com/questions/4949429/where-can-i-find-the-documentation-for-the-particular-kind-of-sql-used-by-the-je
        // https://msdn.microsoft.com/en-us/library/aa139977(office.10).aspx
        // 1.
        if TFile.Exists(FSystemDB)then TFile.Delete(FSystemDB);
        if TFile.Exists(Database)then TFile.Delete(Database);
        sStr:='CREATE_SYSDB='+FSystemDB+chr(0)+chr(0);
        ExecuteBase(ODBC_ADD_DSN, sDrv, sStr);
        if TFile.Exists(FSystemDB+'.mdb')then
        begin
          TFile.Copy(FSystemDB+'.mdb',FSystemDB,true);
          TFile.Delete(FSystemDB+'.mdb');
        end;
        // 2.
        sStr := 'CREATE_DB'; // use DBVersion=avAccess2003
        case DBVersion of
          avAccess2:    sStr := sStr + 'V2';
          avAccess95,
          avAccess97:   sStr := sStr + 'V3';
          avAccess2000,
          avAccess2003: sStr := sStr + 'V4';
        end;
        sStr:=sStr+'='+Database+chr(0)+chr(0);
        ExecuteBase(ODBC_ADD_DSN, sDrv, sStr);
        // 3.
        aFDConnection:=TFDConnection.Create(nil);
        aFDConnection.DriverName:='MSAcc';
        aFDConnection.Params.DriverID:='MSAcc';
        aFDConnection.Params.Values['Database']:=Database;
        aFDConnection.Params.Values['SystemDB']:=FSystemDB;
        aFDConnection.Params.Values['User_Name']:='admin';
        aFDConnection.Open;
        // 4.
        aFDConnection.ExecSQL('CREATE GROUP my_admin_group '+GeneratePID);
        aFDConnection.ExecSQL('CREATE USER '+FUserName+' "" '+GeneratePID);
        aFDConnection.ExecSQL('ADD USER '+FUserName+' TO my_admin_group');
        aFDConnection.ExecSQL('ADD USER '+FUserName+' TO admins');
        // 5.
        aFDConnection.Close;
        aFDConnection.Free;
        if TFile.Exists(Database)then TFile.Delete(Database);
        // 6.
        sStr := 'CREATE_DB'; // use DBVersion=avAccess2003
        lLastDrv := sDrv = 'Microsoft Access Driver (*.mdb, *.accdb)';
        case DBVersion of
        avDefault:    ;
        avAccess2:    sStr := sStr + 'V2';
        avAccess95,
        avAccess97:   sStr := sStr + 'V3';
        avAccess2000,
        avAccess2003: sStr := sStr + 'V4';
        avAccess2007:
          begin
            sDrv := 'Microsoft Access Driver (*.mdb, *.accdb)';
            lLastDrv := True;
          end;
        end;
        sStr := sStr + '=' + NormFileName(Database);
        lSort := SortOrder <> '';
        if lSort and (Pos('0x', SortOrder) = 0) then begin
          sStr := sStr + ' ' + SortOrder;
  {$IFDEF MSWINDOWS}
          lSort := False;
  {$ENDIF}
        end;
        if Encrypted and not lLastDrv then
          sStr := sStr + ' ENCRYPT';
        sStr:='SYSTEMDB='+FSystemDB+chr(0)+'UID='+FUserName+chr(0)+sStr+chr(0)+chr(0);
        ExecuteBase(ODBC_ADD_DSN, sDrv, sStr);
  {$IFDEF MSWINDOWS}
        if (Password <> '') or lSort or (Encrypted and lLastDrv) then begin
          sDb := DestDatabase;
          DestDatabase := '';
          try
            {$IFDEF MSWINDOWS}
            CompactRepair;
            {$ENDIF}
          finally
            DestDatabase := sDb;
          end;
        end;
  {$ENDIF}
        // 7.
        aFDConnection:=TFDConnection.Create(nil);
        aFDConnection.DriverName:='MSAcc';
        aFDConnection.Params.DriverID:='MSAcc';
        aFDConnection.Params.Values['Database']:=Database;
        aFDConnection.Params.Values['SystemDB']:=FSystemDB;
        aFDConnection.Params.Values['User_Name']:=FUserName;
        aFDConnection.Open;
        // 8.
        aFDConnection.ExecSQL('GRANT ALL PRIVILEGES ON DATABASE TO my_admin_group');
        aFDConnection.ExecSQL('REVOKE ALL PRIVILEGES ON DATABASE FROM admin');
        aFDConnection.ExecSQL('REVOKE ALL PRIVILEGES ON DATABASE FROM admins');
        aFDConnection.ExecSQL('REVOKE ALL PRIVILEGES ON DATABASE FROM users');
        // 9.
        aFDConnection.ExecSQL('ALTER USER '+FUserName+' PASSWORD '+FUserPass+' ""');
        // 10.
        //Your database is now secure. But while you are at it, you could create your own version of a ‘users’ group as well. All new users should be made part of this group.
        //CREATE GROUP my_users a_good_pid
        //GRANT whatever privileges ON whatever objects TO my_users
        //ADD my_admin TO my_users
        aFDConnection.Close;
        aFDConnection.Free;
      end else begin

      end;
    end;
  end;
  if DoInherited then inherited;
end;

end.

Usage:

uses FireDAC.Phys.MSAcc, ComTpsDB.MSAccService;
var
  FDPhysMSAccessDriverLink: TFDPhysMSAccessDriverLink;
  FDMSAccessService: TFDMSAccessServiceNew;
begin
  FDPhysMSAccessDriverLink:=TFDPhysMSAccessDriverLink.Create(nil);
  FDMSAccessService:=TFDMSAccessServiceNew.Create(nil);
  FDMSAccessService.DriverLink:=FDPhysMSAccessDriverLink;
  FDMSAccessService.DBVersion:=avAccess2003;
  FDMSAccessService.NeedSystemDB:=true;
  FDMSAccessService.UserName:='my_admin';
  FDMSAccessService.UserPass:='12345678';
  FDMSAccessService.Database:='sample.mdb';
  FDMSAccessService.SystemDB:='sample.mdw';
  // crerate
  FDMSAccessService.CreateDB;
  // compact
  FDMSAccessService.DestDatabase:='sample2.mdb';
  FDMSAccessService.Compact;
  //
  FDPhysMSAccessDriverLink.Free;
  FDMSAccessService.Free;
end;