ado_qimport3access.pas

Advanced Data Import Component Suite for Borland Delphi and C++ Builder allows you to import your da

unit ADO_QImport3Access;

{$I QImport3VerCtrl.Inc}

interface

uses Classes, QImport3, ADODb, DB, QImport3StrTypes, IniFiles;

type
  TQImportAccessSourceType = (isTable, isSQL);

  TADO_QImport3Access = class(TQImport3)
  private
    FSQL: TStrings;
    FTableName: string;
    FPassword: string;
    FSourceType: TQImportAccessSourceType;
    FADO: TADOQuery;
    FSkipCounter: integer;
    procedure SetSQL(const Value: TStrings);
  protected
    procedure StartImport; override;
    function CheckCondition: boolean; override;
    function Skip: boolean; override;
    procedure FillImportRow; override;
    function ImportData: TQImportResult; override;
    procedure ChangeCondition; override;
    procedure FinishImport; override;
    procedure DoLoadConfiguration(IniFile: TIniFile); override;
    procedure DoSaveConfiguration(IniFile: TIniFile); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GetTableNames(List: TqiStrings);{$IFDEF QI_UNICODE}overload;
    procedure GetTableNames(List: TStrings); overload;{$ENDIF}
    procedure GetFieldNames(List: TStrings);


  published
    property FileName;
    property SkipFirstRows default 0;
    property TableName: string read FTableName write FTableName;
    property SQL: TStrings read FSQL write SetSQL;
    property SourceType: TQImportAccessSourceType read FSourceType
      write FSourceType default isTable;
    property Password: string read FPassword write FPassword;
  end;

implementation

uses
  SysUtils, QImport3Common{$IFDEF VCL6}, Variants{$ENDIF},
  ComObj, ActiveX, Dialogs;

const
  SelectFromTable = 'select * from [%s]';
  ConnectionString = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s';
  PasswordString = ';Jet OLEDB:Database Password=%s';

{ TADO_QImport3Access }

constructor TADO_QImport3Access.Create(AOwner: TComponent);
begin
  inherited;
  SkipFirstRows := 0;
  FSourceType := isTable;
  FSQL := TStringList.Create;
  FPassword := EmptyStr;
end;

destructor TADO_QImport3Access.Destroy;
begin
  FSQL.Free;
  inherited;
end;

procedure TADO_QImport3Access.StartImport;
var
  connStr: string;
begin
  if FPassword <> EmptyStr then
    connStr := ConnectionString + Format(PasswordString, [FPassword])
  else
    connStr := ConnectionString;

  FADO := TADOQuery.Create(nil);
  FADO.ConnectionString := Format(connStr, [FileName]);

  if SourceType = isSQL
    then FADO.SQL.Assign(SQL)
    else FADO.SQL.Text := Format(SelectFromTable, [TableName]);
  FADO.Open;

  FSkipCounter := SkipFirstRows;
  if FSkipCounter < 0 then FSkipCounter := 0;
end;

function TADO_QImport3Access.CheckCondition: boolean;
begin
  Result := not FADO.Eof;
end;

function TADO_QImport3Access.Skip: boolean;
begin
  Result := FSkipCounter > 0;
end;

procedure TADO_QImport3Access.FillImportRow;
var
  i, k: Integer;
  SField: TField;
{$IFDEF QI_UNICODE}
  fieldValue: Variant;
{$ENDIF}
  p: Pointer;
  mapValue: qiString;
begin
  FImportRow.ClearValues;
  for i := 0 to FImportRow.Count - 1 do
  begin
    if FImportRow.MapNameIdxHash.Search(FImportRow[i].Name, p) then
    begin
      k := Integer(p);
{$IFDEF VCL7}
      mapValue := Map.ValueFromIndex[k];
{$ELSE}
      mapValue := Map.Values[FImportRow[i].Name];
{$ENDIF}
      if Pos('=', mapValue) > 0 then
        mapValue := Copy(mapValue, 1, Pos('=', mapValue) - 1);
      SField := FADO.FindField(mapValue);
      if Assigned(SField) then
      begin
{$IFDEF QI_UNICODE}
        fieldValue := FADO.Recordset.Fields[mapValue].Value;
        
        if IsCSV and (SField.DataType in [ftDate, ftTime, ftDateTime]) then //for MySQL
          fieldValue := FormatDateTime('yyyy-mm-dd hh:mm:ss', fieldValue);

        if VarIsNull(fieldValue) or VarIsClear(fieldValue) then
          fieldValue := '';
        FImportRow.SetValue(Map.Names[k], fieldValue, SField.IsBlob);
{$ELSE}
        FImportRow.SetValue(Map.Names[k], SField.AsString, SField.IsBlob);
{$ENDIF}
      end;
    end;
    DoUserDataFormat(FImportRow[i]);
  end;
end;

function TADO_QImport3Access.ImportData: TQImportResult;
begin
  Result := qirOk;
  try
    try
      if Canceled  and not CanContinue then
      begin
        Result := qirBreak;
        Exit;
      end;

      DataManipulation;

    except
      on E:Exception do begin
        try
          DestinationCancel;
        except
        end;
        DoImportError(E);
        Result := qirContinue;
        Exit;
      end;
    end;
  finally
    if (not IsCSV) and (CommitRecCount > 0) and not CommitAfterDone and
       (
        ((ImportedRecs + ErrorRecs) > 0)
        and ((ImportedRecs + ErrorRecs) mod CommitRecCount = 0)
       )
    then
      DoNeedCommit;
    if (ImportRecCount > 0) and
       ((ImportedRecs + ErrorRecs) mod ImportRecCount = 0) then
      Result := qirBreak;
  end;
end;

procedure TADO_QImport3Access.ChangeCondition;
begin
  FADO.Next;
  if FSkipCounter > 0 then Dec(FSkipCounter);
end;

procedure TADO_QImport3Access.FinishImport;
begin
  try
    if not Canceled and not IsCSV then
    begin
      if CommitAfterDone then
        DoNeedCommit
      else if (CommitRecCount > 0) and ((ImportedRecs + ErrorRecs) mod CommitRecCount > 0) then
        DoNeedCommit;
    end;
  finally
    {$IFDEF VCL6}
      FADO.Close;
    {$ELSE}
    try
      FADO.Close;
    except
    end;
    {$ENDIF}
    if Assigned(FADO) then FADO.Free;
  end;
end;

procedure TADO_QImport3Access.GetFieldNames(List: TStrings);

  function FieldTypeToStr(ADataType: TFieldType;
                          const AFieldSize: Integer): string;
  begin
    case ADataType of
      ftBlob,
      ftMemo:
        Result := 'Memo';
      ftWideString,
      ftString,
      ftGuid:
        Result := Format('Text(%d)', [AFieldSize]);
      ftAutoInc:
        Result := 'AutoNumber';
      ftSmallint,
      ftInteger,
      ftWord,
      ftLargeInt,
      ftFloat,
      {$IFDEF VCL6}ftFMTBcd,{$ENDIF}
      ftBCD:
        Result := 'Number';
      ftBoolean:
        Result := 'Yes/No';
      ftCurrency:
        Result := 'Currency';
      ftDate,
      ftTime,
      {$IFDEF VCL6}ftTimeStamp,{$ENDIF}
      ftDateTime:
        Result := 'Date/Time';
    else
      Result := 'Unknown';
    end;
  end;

var
  ADO: TADOQuery;
  connStr: string;
  i: Integer;
  fd: TFieldDef;
begin
  if FPassword <> EmptyStr then
    connStr := ConnectionString + Format(PasswordString, [FPassword])
  else
    connStr := ConnectionString;

  ADO := TADOQuery.Create(nil);
  try
    ADO.ConnectionString := Format(connStr, [FileName]);
    if SourceType = isSQL then
      ADO.SQL.Assign(Self.SQL)
    else
      ADO.SQL.Text := Format(SelectFromTable, [TableName]);

    if ADO.SQL.Text <> '' then
    begin
      ADO.Open;
      try
        for i := 0 to ADO.FieldCount - 1 do
        begin
          fd := ADO.FieldDefList.FieldDefs[i];
          if fd <> nil then
          begin
            List.Values[fd.Name] := FieldTypeToStr(fd.DataType, fd.Size);
            List.Objects[i] := TObject(fd.DataType);
          end;
        end;
      finally
        ADO.Close;
      end;
    end;
  finally
    ADO.Free;
  end;
end;

procedure TADO_QImport3Access.GetTableNames(List: TqiStrings);
var
  ADO: TADOConnection;
  connStr: string;
  Names: TStrings;
begin
  if FPassword <> EmptyStr then
    connStr := ConnectionString + Format(PasswordString, [FPassword])
  else
    connStr := ConnectionString;

  ADO := TADOConnection.Create(nil);
  try
    ADO.LoginPrompt := false;
    ADO.ConnectionString := Format(connStr, [FileName]);
    ADO.Open;
    Names := TStringList.Create;
    try
      ADO.GetTableNames(Names, false);
      List.Assign(Names);
    finally
      ADO.Close;
      Names.Free;
    end;
  finally
    ADO.Free;
  end;
end;

{$IFDEF QI_UNICODE}
procedure TADO_QImport3Access.GetTableNames(List: TStrings);
var
  ADO: TADOConnection;
  connStr: WideString;
  Names: TStrings;
begin
  if FPassword <> EmptyStr then
    connStr := ConnectionString + Format(PasswordString, [FPassword])
  else
    connStr := ConnectionString;

  ADO := TADOConnection.Create(nil);
  try
    ADO.LoginPrompt := false;
    ADO.ConnectionString := Format(connStr, [FileName]);
    ADO.Open;
    Names := TStringList.Create;
    try
      ADO.GetTableNames(Names, false);
      List.Assign(Names);
    finally
      ADO.Close;
      Names.Free;
    end;
  finally
    ADO.Free;
  end;
end;
{$ENDIF}

procedure TADO_QImport3Access.SetSQL(const Value: TStrings);
begin
  FSQL.Assign(Value);
end;

//**************************************************************************
//
//  Access Password Encrypt/Decrypt
//
//**************************************************************************

function StringToHex(const Str: String): String;
const
	HexDigits: array[0..15] of Char = '0123456789abcdef';
var
	I: Integer;
	B: Byte;
begin
	Result := '';
	for I := 1 to Length(Str) do
	begin
		B := Ord(Str[I]);
		Result := Result + HexDigits[B shr 4] + HexDigits[B and 15];
	end;
end;

function HexToString(const HexStr: string; out Str: string): Boolean;
var
	I: Integer;
	V, B: Byte;
  Res: string;
begin
  Str := '';
  Result := Length(HexStr) mod 2 = 0;
  if not Result then
    Exit;
  V := 0;
  B := 0;
  Res := '';
  for I := 1 to Length(HexStr) do
  begin
    case HexStr[I] of
      '0': B := 0;
      '1': B := 1;
      '2': B := 2;
      '3': B := 3;
      '4': B := 4;
      '5': B := 5;
      '6': B := 6;
      '7': B := 7;
      '8': B := 8;
      '9': B := 9;
      'a', 'A': B := 10;
      'b', 'B': B := 11;
      'c', 'C': B := 12;
      'd', 'D': B := 13;
      'e', 'E': B := 14;
      'f', 'F': B := 15;
      else begin
        Result := False;
        Exit;
      end;
    end;
    V := V shl 4 + B;
    if I mod 2 = 0 then
    begin
      Res := Res + Chr(V);
      V := 0;
    end;
  end;
  Str := Res;
end;

function SimpleXOR(const text: string): string;
const
  key = #9#8#7#6#5#4#3#2#1#0;
var
  longkey: string;
  i: integer;
  toto: char;
begin
  Result := '';
  for i := 0 to (length(text) div length(key)) do
    longkey := longkey + key;
  for i := 1 to length(text) do
  begin
    toto := chr((ord(text[i]) xor ord(longkey[i])));
    result := result + toto;
  end;
end;

function adler32(const buf : string; len : Cardinal) : Cardinal;
var
  s1, s2: Cardinal;
  I: Integer;
begin
  s1 := Cardinal(1);
  s2 := Cardinal(0);
  for I := 0 to len - 1 do
  begin
    s1 := (s1 + Ord(buf[i+1]))  mod Cardinal(65521);
    s2 := (s2 + s1)             mod Cardinal(65521);
  end;
  Result := (s2 shl 16) + s1;
end;

type
  TAdlerRec = packed record
    case Integer of
      0: (b1, b2, b3, b4: Byte);
      1: (Adler: Cardinal);
  end;

function AdlerStr(adler: Cardinal): string;
var
  a: TAdlerRec;
begin
  a.Adler := adler;
  Result := Char(a.b1)+Char(a.b2)+Char(a.b3)+Char(a.b4);
end;

function AdlerNum(str: string): Cardinal;
var
  a: TAdlerRec;
begin
  a.b1 := Byte(str[1]);
  a.b2 := Byte(str[2]);
  a.b3 := Byte(str[3]);
  a.b4 := Byte(str[4]);
  Result := a.adler;
end;

function PasswordDecrypt(const HexStr: string): string;
var
  Pass, S: string;
  a: Cardinal;
begin
  Result := HexStr;
  if HexStr = '' then
    Exit;

  if HexToString(HexStr,Pass) then
  begin
    if Length(Pass) > 4 then
    begin
      s := Copy(Pass,5,length(Pass)-4);
      a := adler32( S, Length(s));
      if AdlerNum(Pass) = a then
      begin
        Result := SimpleXOR(s);
      end;
    end;
  end;
end;

function PasswordEncrypt(const Password: string): string;
var
  pass, prefix: string;
  a: Cardinal;
begin
  Result := '';
  if Password = '' then
    Exit;

  pass := SimpleXOR(Password);
  a := adler32( Pass, Length(Pass));
  prefix := AdlerStr( a );

  Result := StringToHex(prefix + pass);
end;

//**************************************************************************

procedure TADO_QImport3Access.DoLoadConfiguration(IniFile: TIniFile);
var
  AStrings: TStrings;
  i : Integer;
begin
  inherited;
  with IniFile do
  begin
    SkipFirstRows := ReadInteger(ACCESS_OPTIONS, ACCESS_SKIP_LINES, SkipFirstRows);
    SourceType := TQImportAccessSourceType(ReadInteger(ACCESS_OPTIONS, ACCESS_SOURCE_TYPE, Integer(SourceType)));
    TableName := ReadString(ACCESS_OPTIONS, ACCESS_TABLE_NAME, TableName);
    Password := PasswordDecrypt(ReadString(ACCESS_OPTIONS, ACCESS_PASSWORD, EmptyStr));
    AStrings := TStringList.Create;
    try
      AStrings.Clear;
      SQL.Clear;
      ReadSection(ACCESS_SQL, AStrings);
      for i := 0 to AStrings.Count - 1 do
        SQL.Add( ReadString(ACCESS_SQL, AStrings[i], EmptyStr) );
    finally
      AStrings.Free;
    end;
  end;
end;

procedure TADO_QImport3Access.DoSaveConfiguration(IniFile: TIniFile);
var
  i : Integer;
begin
  inherited;
  with IniFile do
  begin
    WriteInteger(ACCESS_OPTIONS, ACCESS_SKIP_LINES, SkipFirstRows);
    WriteInteger(ACCESS_OPTIONS, ACCESS_SOURCE_TYPE, Integer(SourceType));
    WriteString(ACCESS_OPTIONS, ACCESS_TABLE_NAME, TableName);
    WriteString(ACCESS_OPTIONS, ACCESS_PASSWORD, PasswordEncrypt( Password ));
    EraseSection(ACCESS_SQL);
    for i := 0 to SQL.Count - 1 do
      WriteString(ACCESS_SQL, Format('%s%.3d',[ACCESS_SQL_LINE,i+1]), SQL.Strings[i]);
  end;
end;


initialization
  CoInitialize(nil);

finalization
  CoUninitialize;

end.