unit ADO_QExport4Access;

interface

{$I QExport4VerCtrl.inc}
{$IFDEF ADO}
uses
  {$IFDEF VCL16}
    System.Classes,
    Data.Win.ADODB,
    System.SysUtils,
    Data.DB,
    Vcl.Dialogs,
    System.Win.ComObj,
    System.Variants,
  {$ELSE}
    Classes,
    ADODB,
    SysUtils,
    DB,
    Dialogs,
    ComObj,
    {$IFDEF VCL6}
      Variants,
    {$ENDIF}
  {$ENDIF}
  QExport4,
  ADO_QExport4Database,
  QExport4Types,
  QExport4IniFiles;

type
  EAccessCreateDataBase = class(Exception);

  TAccessFileVersion = (afvAccess2003, afvAccess2007, afvAccess2013);

  TQAccessWriter = class(TQExportWriter)
  private
    FADOCommandInsert: TADOCommand;
    procedure CreateTable(const ConnectStr: string; const TableName, Command: string);
    procedure CreateInsertCommand(const ConnectStr: string; const FName: string;
      const InsertCommandDML: string; ParamTypes: array of TFieldType);
    procedure CreateAccessDatabase(const ConnectStr: String; const DatabaseFile: string);
  public
    constructor Create(AOwner: TQExport4; AStream: TStream); override;
    destructor Destroy; override;
    procedure WriteData(Num: integer; const Data: QEString);
  end;

  TADO_QExport4Access = class(TQExport4Database)
  private
    FFileVersion: TAccessFileVersion;
    FOleObject: Variant;
    FPassword: string;
    FDateTimeAsNvarchar: Boolean;
    FLargeIntAsText: Boolean;
    procedure SetPassword(const Value: string);
  protected
    function GetWriterClass: TQExportWriterClass; override;
    function GetWriter: TQAccessWriter;
    procedure BeginExport; override;
    procedure WriteDataRow; override;
    procedure DoShowResult; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SaveProperties(IniFile: TQIniFile); override;
    procedure LoadProperties(IniFile: TQIniFile); override;
  published
    property Password: string read FPassword write SetPassword;
    property DatabaseName; // FileName
    property TableName;
    property AutoCreateDatabase default True;
    property AutoCreateTable default True;
    property DateTimeAsNvarchar: Boolean read FDateTimeAsNvarchar
      write FDateTimeAsNvarchar default False;
    property LargeIntAsText: Boolean read FLargeIntAsText
      write FLargeIntAsText default True;
    property FileVersion: TAccessFileVersion read FFileVersion
      write FFileVersion default afvAccess2003;
    property ShowFile default False;
    property PrintFile default False;
  end;
{$ENDIF}

implementation

{$IFDEF ADO}
uses
  {$IFDEF VCL16}
    Winapi.ShellAPI,
    Winapi.Windows,
  {$ELSE}
    ShellAPI,
    Windows,
  {$ENDIF}
  QExport4StrIDs, QExport4Common;

const
  ConnectionString2003 = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source="%s"';
  ConnectionString2007 = 'Provider=Microsoft.ACE.OLEDB.12.0;Data Source="%s"';
  ConnectionString2013 = 'Provider=Microsoft.ACE.OLEDB.15.0;Data Source="%s"';  
  PasswordString = ';Jet OLEDB:Database Password=%s';
  CreateTableDDL = 'create table %s (%s)';
  InsertDML = 'insert into %s(%s) values(%s)';
  TableNameDef = 'ExportResult';
  BeginTableNameQuote = '[';
  EndTableNameQuote = ']';

function GetUnQuotedTableName(const ATableName: qeString): qeString;
var
  StrLen: Integer;
begin
  Result := ATableName;
  StrLen := Length(Result);
  if (Pos(BeginTableNameQuote, Result) = 1) and
    (Pos(EndTableNameQuote, Result) = StrLen) then
    Result := Copy(Result, 2, StrLen - 2);
end;

function GetQuotedTableName(const ATableName: qeString): qeString;
begin
  Result := BeginTableNameQuote + GetUnQuotedTableName(ATableName) +
    EndTableNameQuote;
end;

constructor TADO_QExport4Access.Create(AOwner: TComponent);
begin
  inherited;
  TableName := TableNameDef;
  AutoCreateTable := True;
  AutoCreateDatabase := True;
  DateTimeAsNvarchar := False;
  LargeIntAsText := True;
  ShowFile := False;
  PrintFile := False;
  FPassword := EmptyStr;
  Formats.KeepOriginalFormat := True; //False; #DATEXP-927
  FileVersion := afvAccess2003;
end;

function TADO_QExport4Access.GetWriter: TQAccessWriter;
begin
  Result := TQAccessWriter(inherited GetWriter);
end;

function TADO_QExport4Access.GetWriterClass: TQExportWriterClass;
begin
  Result := TQAccessWriter;
end;

procedure TADO_QExport4Access.LoadProperties(IniFile: TQIniFile);
begin
  inherited LoadProperties(IniFile);
  FileVersion := TAccessFileVersion(IniFile.ReadInteger(S_ACCESS,
    S_ACCESS_Version, Integer(FileVersion)));
end;

procedure TADO_QExport4Access.BeginExport;
var
  i: integer;
  CreateFieldsList,
  InsertFieldsList,
  InsertParamsList,
  FieldName,
  FieldSQLType,
  ConnectionString: String;
  FieldTypes: array of TFieldType;
  F: TField;
begin
  inherited;
  CreateFieldsList := '';
  InsertFieldsList := '';
  InsertParamsList := '';
  SetLength(FieldTypes, Columns.Count);
  for i := 0 to Columns.Count - 1 do
  begin
    FieldName := inherited GetColCaption(i);
    if FieldName = '' then
      FieldName := Format('FIELD%d', [i])
    else
      FieldName := Format('[%s]', [FieldName]);
    case Columns[i].ColType of
      ectInteger, ectBigint:
        begin
          FieldSQLType := 'integer';
          FieldTypes[i] := ftInteger;

          if FLargeIntAsText and (Columns[i].ColType = ectBigint) and
            (Columns[i].FieldType = ftLargeint) then
            begin
              //FieldSQLType := Format('nvarchar(%d)', [19]);
              FieldTypes[i] := ftLargeint; //ftWideString;  // #DATEXP-897
            end;
        end;
      ectString:
        begin
          if Columns[i].IsBlob or Columns[i].IsMemo or
            (Columns[i].Length > 255) then
          begin
            FieldSQLType:='memo';
            FieldTypes[i] := ftMemo;
          end else
          begin
            FieldSQLType := Format('nvarchar(%d)', [Columns[i].Length]);
            FieldTypes[i] := ftWideString;
          end;
        end;
      ectFloat:
        if Assigned(DataSet) and Assigned(DataSet.FindField(GetColCaption(i))) then
        begin
          FieldTypes[i] := ftFloat;
          FieldSQLType := 'double';
        end;
      ectNumeric:
        if Assigned(DataSet) then
        begin
          F := DataSet.FindField(GetColCaption(i));
          FieldTypes[i] := ftString;//ADO don't support ftFmtBCD types
          if (Columns[i].NumPrecision = 0) or
            (Assigned(F) and (F.DataType = ftFmtBCD)) then
            FieldSQLType := 'decimal(18,10)'
          else
            FieldSQLType := 'decimal('+ IntToStr(Columns[i].NumPrecision) +','+ IntToStr(Columns[i].NumSize) +')';
        end;
      ectCurrency:
        begin
          {$IFDEF POSTGRESQL}
          FieldSQLType := 'memo';
          FieldTypes[i] := ftMemo;
          {$ELSE}
          FieldSQLType := 'currency';
          FieldTypes[i] := ftCurrency;
          {$ENDIF}
        end;
      ectDate, ectTime, ectDateTime:
        begin
          if not FDateTimeAsNvarchar then
          begin
            FieldSQLType := 'datetime';
            FieldTypes[i] := ftDateTime;
          end else
          begin
            FieldSQLType := Format('nvarchar(%d)', [20]);
            FieldTypes[i] := ftWideString;
          end;
        end;
      ectBoolean:
        begin
          FieldSQLType := 'LOGICAL';
          FieldTypes[i] := ftBoolean;
        end;
      else begin
        FieldSQLType := 'memo';
        FieldTypes[i] := ftMemo;
      end;
    end;
    if i > 0 then
    begin
      CreateFieldsList := CreateFieldsList + ',';
      InsertFieldsList := InsertFieldsList + ',';
      InsertParamsList := InsertParamsList + ',';
    end;
    CreateFieldsList := CreateFieldsList + FieldName + ' ' + FieldSQLType;
    InsertFieldsList := InsertFieldsList + FieldName;
    InsertParamsList := InsertParamsList + Format(':PARAM%d', [i]);
  end;

  if FileVersion = afvAccess2003 then
    ConnectionString := ConnectionString2003
  else if FileVersion = afvAccess2007 then
    ConnectionString := ConnectionString2007
  else if FileVersion = afvAccess2013 then
    ConnectionString := ConnectionString2013;

  if FPassword <> EmptyStr then
    ConnectionString := ConnectionString + Format(PasswordString, [FPassword]);

  if AutoCreateDatabase then
     GetWriter.CreateAccessDatabase(ConnectionString, DatabaseName);

  if AutoCreateTable then
    GetWriter.CreateTable(Format(ConnectionString, [DatabaseName]),
      TableName, Format(CreateTableDDL, [
        GetQuotedTableName(TableName), CreateFieldsList]));

    GetWriter.CreateInsertCommand(ConnectionString, DatabaseName,
        Format(InsertDML, [GetQuotedTableName(TableName), InsertFieldsList,
          InsertParamsList]), FieldTypes);
  SetLength(FieldTypes, 0);
end;

procedure TADO_QExport4Access.WriteDataRow;
var
  i: integer;
  str: QEString;
begin
  for i := 0 to ExportRow.Count - 1 do begin
    str := GetExportedValue(ExportRow[i]);//.GetExportedValue{(False) ab TODO}; //inherited GetColData(i, False);
    if str = Formats.NullString then
      str := '';
    GetWriter.WriteData(i, str);
  end;
  GetWriter.FADOCommandInsert.Execute;
end;

procedure TADO_QExport4Access.DoShowResult;
var
  arg1, arg2, arg3: OleVariant;
begin
  if {ShowFile or }PrintFile then begin
    FOleObject := Unassigned;
    try
      FOleObject := CreateOleObject('Access.Application');
    except
      on E: EOleError do begin
         FOleObject := Unassigned;
         raise Exception.Create(QExportLoadStr(QEM_ExportAccessOleError));
      end;
    end;
    FOleObject.OpenCurrentDatabase(DatabaseName, False);
    arg1 := TableName;
    arg2 := 0;
    arg3 := 1;
    if ShowFile then FOleObject.Visible := true;
    FOleObject.DoCmd.OpenTable(arg1, arg2, arg3);
    if PrintFile then FOleObject.DoCmd.PrintOut;
    if not ShowFile then FOleObject := Unassigned;
  end else
  if ShowFile then
    ShellExecute(0, 'open', PChar(DatabaseName), '', '', SW_SHOWNORMAL);
end;

//****TQAceessWriter**********************************************************

constructor TQAccessWriter.Create(AOwner: TQExport4; AStream: TStream);
begin
   inherited;
   FADOCommandInsert:=TADOCommand.Create(nil);
   FADOCommandInsert.ExecuteOptions := [eoExecuteNoRecords];
end;

destructor TQAccessWriter.Destroy;
begin
   FADOCommandInsert.Free;
   FADOCommandInsert := nil;
   inherited;
end;

procedure TQAccessWriter.CreateTable(const ConnectStr: string; const TableName, Command: string);

var
  FADOCommandDDL: TADOCommand;
  Tables: TStrings;
  TableExists: boolean;
  FConnection: TADOConnection;
begin
  FConnection := TADOConnection.Create(nil);
  try
    FConnection.ConnectionString := ConnectStr;
    FConnection.LoginPrompt := False;
    FConnection.Open;
    try
      Tables := TStringList.Create;
      try
        {$IFDEF EXPORT}
          FConnection.GetTableNames(Tables, False);
        {$ELSE}
          FConnection.GetTableNames(Tables, False);
        {$ENDIF}

        TableExists := Tables.IndexOf(GetUnQuotedTableName(TableName)) > -1;
      finally
        Tables.Free;
      end;
    finally
      FConnection.Close;
    end;
  finally
    FConnection.Free;
  end;

  if TableExists then Exit;

  FADOCommandDDL := TADOCommand.Create(nil);
  try
    FADOCommandDDL.ConnectionString := ConnectStr;
    FADOCommandDDL.CommandText := Command;
    FADOCommandDDL.Execute;
  finally
    FADOCommandDDL.Free;
  end;
end;

procedure TQAccessWriter.CreateInsertCommand(const ConnectStr: string;
  const FName: string; const InsertCommandDML: string;
  ParamTypes: array of TFieldType);
var
  i: integer;
begin
  FADOCommandInsert.ConnectionString := Format(ConnectStr, [FName]);
  FADOCommandInsert.CommandText := InsertCommandDML;
  for i := 0 to Length(ParamTypes) - 1 do
    FADOCommandInsert.Parameters[i].DataType := ParamTypes[i];
  FADOCommandInsert.ExecuteOptions := [eoExecuteNoRecords];
  FADOCommandInsert.Prepared := True;
end;

procedure TQAccessWriter.CreateAccessDatabase(const ConnectStr: String;
  const DatabaseFile: string);
var
  cat: OleVariant;
begin
  if FileExists(DatabaseFile) then Exit;
  cat := CreateOleObject('ADOX.Catalog');
  if not VarIsEmpty(cat) then
  try
    cat.Create(Format(ConnectStr, [DatabaseFile]));
    cat := Null;
  except
    raise EAccessCreateDataBase.Create(
      QExportLoadStr(QEM_CreateAccessDatabaseError));
  end;
end;

procedure TQAccessWriter.WriteData(Num: integer; const Data: QEString);
begin
  if Data = '' then
    FADOCommandInsert.Parameters[Num].Value := Unassigned
  else
    FADOCommandInsert.Parameters[Num].Value := Data;
end;

procedure TADO_QExport4Access.SaveProperties(IniFile: TQIniFile);
begin
  inherited SaveProperties(IniFile);
  IniFile.WriteInteger(S_ACCESS, S_ACCESS_Version, Integer(FileVersion));
end;

procedure TADO_QExport4Access.SetPassword(const Value: string);
begin
  FPassword := Value;
end;
{$ENDIF}

end.
