Многопоточная запись в базу данных access

implementation
 
{$R *.dfm}
var
 Potoks: array [1..12] of TPotok;
 n:integer;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
for n:=1 to 12 do
begin
Potoks[n]:=TPotok.Create(n);
 
end;
end;
 
constructor TPotok.Create(i:integer);
begin
Cnt:=i;
inherited Create(False);
FreeOnTerminate:=True;
end;
 
procedure TPotok.Execute;
var
Q:TADOQuery;
t:integer;
begin
CoInitialize(nil);
try
Form1.Label1.Caption := inttostr(Cnt);
Q:=TADOQuery.Create(Application);
Q.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source=F:\shar\multyaccessADO\ADO\thread.mdb; Persist Security Info=False;Jet OLEDB:Database Password=""';
try
for t:=1 to 1000 do
  begin
  Q.Close;
  Q.SQL.Clear;
  Q.SQL.Add('INSERT INTO Example (N, AddTime, NumItem) VALUES ("'+IntToStr(Cnt)+'","'+DateTimeToStr(Now)+'","'+IntToStr(t)+'")');
  Q.ExecSQL;
  end;
 
     finally
      Q.Free;
    end;
  finally
    CoUninitialize;
  end
end;

Form1.Label1.Caption := inttostr(Cnt);

Synchronize(procedure begin Form1.Label1.Caption := inttostr(Cnt); end);

//------------------------------------------------------------------------------
function TMainForm.GetParentWindowHandleForDialogs : HWND;
  begin
     try
      if Assigned(Screen.ActiveCustomForm) then begin
        Result := Screen.ActiveCustomForm.Handle;
      end else if Assigned(Application.MainForm) then begin
        Result := Application.MainFormHandle;
      end else begin
        Result := Application.Handle;
      end;
     except
     on E: Exception do
           ShowMessage(E.Message);
     end;
  end;
 
//------------------------------------------------------------------------------
function TMainForm.DMyShowMessage(const Msg,  Caption: string;
                                  const vtupe: integer) : integer ;
    begin
        Result := MessageBox(GetParentWindowHandleForDialogs,
                              PChar(Msg), PChar(Caption), vtupe);
    end;
//------------------------------------------------------------------------------
procedure TMainForm.Databaseeditor1Click(Sender: TObject);
begin
        BDmanager.Form2.Show;
end;

//------------------------------------------------------------------------------
procedure TMainForm.TestProvider;
  Function CheckMSProviderVersion: TProviderNum;
    Const
      CLSID_JETOLEDB_4_00: TGUID = '{DEE35070-506B-11CF-B1AA-00AA00B8DE95}';
      CLSID_ACEOLEDB_12_0: TGUID = '{3BE786A0-0366-4F5C-9434-25CF162E475E}';
      CLSID_ACEOLEDB_16_0: TGUID = '{3BE786A2-0366-4F5C-9434-25CF162E475E}';
      Var
        hR : HRESULT;
        OutParam : IUnknown;
      var
      iTmp, i: integer;
      Begin
        iTmp := Low(BDVar.ProviderArray);
        for i := iTmp to High(BDVar.ProviderArray) do
          begin
             BDVar.ProviderArray[i] := ePrNll;
          end;
        Result := ePrNot;
 
        hR := CoCreateInstance(CLSID_JETOLEDB_4_00,  Nil,  CLSCTX_INPROC_SERVER,
        IID_IDBInitialize,  OutParam);
      If (hR = S_OK) And (OutParam <> Nil) Then
      Begin
        OutParam := Nil;
        Result := ePr4;
        BDVar.ProviderArray[iTmp] := Result;
        INC(iTmp);
 
      End;
        hR := CoCreateInstance(CLSID_ACEOLEDB_12_0,  Nil,  CLSCTX_INPROC_SERVER,
        IID_IDBInitialize,  OutParam);
      If (hR = S_OK) And (OutParam <> Nil) Then
      Begin
        OutParam := Nil;
        Result := ePr12;
        BDVar.ProviderArray[iTmp] := Result;
       INC(iTmp);
 
      End;
        hR := CoCreateInstance(CLSID_ACEOLEDB_16_0,  Nil,  CLSCTX_INPROC_SERVER,
        IID_IDBInitialize,  OutParam);
      If (hR = S_OK) And (OutParam <> Nil) Then
      Begin
        OutParam := Nil;
        Result := ePr16;
        BDVar.ProviderArray[iTmp] := Result;
        INC(iTmp);
      End;
      if(iTmp > Low(BDVar.ProviderArray))then
      begin
         Result := ePrInn;
         BDVar.ProviderCnt := iTmp - 1;
      end else BDVar.ProviderCnt := Low(BDVar.ProviderArray);
End;
  begin
  BDvar.ProviderNum := ePrNot;
    Case CheckMSProviderVersion of
 
      ePrNot: MainForm.MyShowMessageErr('Не установлен MS Provider .. ', 'Ошибка');
      ePrInn: ConectProvider(BDvar, ePrInn);
      ePr4 : ConectProvider(BDvar, ePr4); // Microsoft.Jet.OLEDB.4.0
      ePr12: ConectProvider(BDvar, ePr12); // Microsoft.ACE.OLEDB.12.0
      ePr16: ConectProvider(BDvar, ePr16); //Microsoft.ACE.OLEDB.16.0
 
    Else MainForm.MyShowMessageErr('MS Provider не определен .. ', 'Ошибка');
  end;
end;

 
***
 Case prvar.ProviderArray[prvar.ProviderCnt] of
        ePr4 : BDVar.ProviderName := StrArray[0]; // Microsoft.Jet.OLEDB.4.0
        ePr12: BDVar.ProviderName := StrArray[1]; // Microsoft.ACE.OLEDB.12.0
        ePr16: BDVar.ProviderName := StrArray[2]; //Microsoft.ACE.OLEDB.16.0
      Else BDVar.ProviderName := StrArray[0];
      end;
***
BDVar.fConString := 'Provider=' + BDVar.ProviderName + 'Data Source=' +
                          BDVar.PathBD
                           //+ ';Persist Security Info=True;Password=123'//+ PasswordBD User ID=admin; <<-- тут выскакивает ошибка хотя пароли совпадают без пароля работает 
                           +';Persist Security Info=False;'
                           ;
***

//------------------------------------------------------------------------------
procedure TMainForm.FormCreate(Sender: TObject);
var
b : boolean;
begin
    with MainForm do
      begin
       BorderStyle  := bsSizeToolWin;
       //align        :=alclient;
       windowstate  :=wsMaximized;
       //FormStyle:=fsStayOnTop;
       Left         := 0;
       Top          := 0;
       Height       := Screen.Height;
       Width        := Screen.Width;
     end;
     //--***************************************************************--------
     PathInApplication := ExtractFilePath(GetModuleName(0));
     NameInApplication  := ExtractFileName(GetModuleName(0));
     PasswordBD := Password;
       BDVar.PathBD := PathInApplication  + DataFoider
                      + DatabaseFolder ;
       if DirectoryExists(BDVar.PathBD) then
          begin
           BDVar.PathBD := BDVar.PathBD + NameBase;
              if FileExists(BDVar.PathBD) then
                TestProvider
                else
                begin
                   MainForm.MyShowMessageQUEST('Отсутствует база данных!' + CR +
                                                  'Указать путь к базе данных?',
                                                  'Ошибка', b);
                  if b  then
                    begin
                                                           //...
                    if OpenDialog.Execute then            // Не доработано
                    BDVar.PathBD := OpenDialog.FileName;  //  Доработать
                                                          //...
                    end else
                    Application.Terminate;
                end;
          end
       else
          begin
            MainForm.MyShowMessageErr('Отсутствует каталог с базой данных!',
                                                                  'Ошибка');
            Application.Terminate;
          end;
          //--***************************************************************---
 
 
 
end;
//------------------------------------------------------------------------------
procedure TMainForm.FormShow(Sender: TObject);
begin
     try
          ADOQuery1.Active := False;
          ADOConnection1.Close;
          ADOConnection1.ConnectionString := BDVar.fConString;
          ADOConnection1.Open();
          ADOConnection1.Connected := True;
          ADOQuery1.SQL.Clear;
          ADOQuery1.SQL.Add('SELECT * FROM ' + NameTableDB);
          ADOQuery1.Open;
          BDVar.fReConectBase := True;
      except
      on E: Exception do
      begin
      MainForm.MyShowMessageErr(E.ClassName+' Не удалось подключится к базе, код ошибки: '
                                 + E.Message + ' ' + CR + ' ' + 'Provider= ' + BDVar.ProviderName, 'Ошибка');
          BDVar.fReConectBase := False;
                  //  Тут дописать необходим действия в случае ошибки
                  //
 
      end;
     end;
end;
 
//------------------------------------------------------------------------------

//------------------------------------------------------------------------------
procedure TMainForm.FileOpen1Execute(Sender: TObject);
var
  Od : TOpenDialog;
begin
  //Диалог выбора файла.
  Od := OpenDialog;
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath(ParamStr(0));
    Od.Options := [ofFileMustExist];
 
   Od.Filter := 'Las files (*.las)|*.las|CSV files (*.csv)|*.CSV|Excel files (*.xls;*.xlsx)|*.xls;*.xlsx|Text files (*.txt)|*.txt|All files|*.*';;
   Od.FilterIndex := 1;
    if not Od.Execute then
    Exit;
      if not FileExists(Od.FileName) then
  begin
    MainForm.MyShowMessageErr('Файл с заданным именем не найден! Действие отменено.',
                                                                        'Ошибка');
    Exit;
  end;
 
  //if OpenDialog.Execute then
    CreateMDIChild(Od.FileName);
end;
 
***
 
//------------------------------------------------------------------------------
procedure TMainForm.CreateMDIChild(const Name: string);
var
  Child: TMDIChild;
  Fs : TFileStream;
  S  : UTF8String;  //UTF8String = AnsiString.
  stmp : string;
var
  Ex : OleVariant;
begin
 
  Child := TMDIChild.Create(Application);{ create a new MDI child window }
  Child.Caption := Name;
  stmp := ExtractFileExt(Name);
  if (stmp = '.txt') or (stmp = '.las') or (stmp = '.CSV')then
  begin
  if FileExists(Name) then
  begin
   //Загрузка данных из файла и их обработка.
  Fs := TFileStream.Create(Name, fmOpenRead + fmShareDenyWrite);
  try
    SetString(S, PChar(#0#0#0), 3);
    if (Fs.Read(S[1], 3) < 3) or (S <> #$EF#$BB#$BF) then
      Fs.Position := 0;
      SetLength(S, Fs.Size - Fs.Position);
      Fs.Read(S[1], Fs.Size);
      Child.Memo1.Text := UTF8Decode(S);
    finally
        FreeAndNil(Fs);
    end;
 
  end;
  end else
  if (stmp = '.xlsx') or (stmp = '.xls') then
  begin
   // Ex := CreateOleObject('Excel.Application');
   // Ex.Visible := False;  // скрыть Excel
                                // True;   // показать Excel
   // Ex.Application.DisplayAlerts:= True;   // показывать предупреждения
                                // False;  // не показывать предупреждения (игнорировать)
  end;
end;

 try
 
        MainForm.ADOQuery1.Insert;
        MainForm.ADOQuery1.FieldByName('datet').AsDateTime := t;
        MainForm.ADOQuery1.FieldByName('pressure1').AsFloat:= df ;
        MainForm.ADOQuery1.FieldByName('pressure2').AsFloat:= df2;
        MainForm.ADOQuery1.FieldByName('temperature').AsFloat:= tf;
        MainForm.ADOQuery1.FieldByName('depths').AsFloat:= 1.0;//пока нет данных
        MainForm.ADOquery1.Next;
        //MainForm.ADOQuery1.Active:=True;
      except
      on e:Exception do
      end;

Add('INSERT INTO Example (N, AddTime, NumItem) VALUES ("'+IntToStr(Cnt)+'","'+DateTimeToStr(Now)+'","'+IntToStr(t)+'")');

FDQuery1.SQL.Text := 'insert into MyTab values (:p1, :p2, :p3)';
// here FDQuery1.Params collection is filled by 3 parameters
FDQuery1.Params.ArraySize := 100;
for i := 0 to 100-1 do begin
  FDQuery1.Params[0].AsIntegers[i] := i;
  FDQuery1.Params[1].AsStrings[i] := 'qwe';
  FDQuery1.Params[2].Clear(i);
end;
FDQuery1.Execute(100, 0);

FDQuery1.Params.ArraySize := 100;

FDQueryAddINDI.SQL.Text := 'insert into indi values ('
  + ':indikey, :hasdata, :gedcomnames, :sex, :birthdate, :died, '
  + ':deathdate, :changed, :eventlinesneedprocessing, :eventlines, '
  + ':famc, :fams, :linkinfo, :todo, :nextreportindi, :firstancestralloop'
  + ')';
FDQueryAddINDI.Params.Bindmode := pbByNumber; {more efficient than by name }
FDQueryAddINDI.Params.ArraySize := MaxParams; { large enough to load all of them } 
 
NumParams := 0;
repeat
  { the code to determin IndiKey,... is not shown, but goes here }
 
  FDQueryAddINDI.Params[0].AsStrings[NumParams] := IndiKey;   
  FDQueryAddINDI.Params[1].AsIntegers[NumParams] := HasData;
  FDQueryAddINDI.Params[2].AsStrings[NumParams] := GedcomNames;
  FDQueryAddINDI.Params[3].AsStrings[NumParams] := Sex;
  FDQueryAddINDI.Params[4].AsStrings[NumParams] := Birthdate;
  FDQueryAddINDI.Params[5].AsIntegers[NumParams] := Died;
  FDQueryAddINDI.Params[6].AsStrings[NumParams] := Deathdate;
  FDQueryAddINDI.Params[7].AsStrings[NumParams] := Changed;
  FDQueryAddINDI.Params[8].AsIntegers[NumParams] := EventLinesNeedProcessing;
  FDQueryAddINDI.Params[9].AsStrings[NumParams] := EventLines;
  FDQueryAddINDI.Params[10].AsIntegers[NumParams] := FamC;
  FDQueryAddINDI.Params[11].AsIntegers[NumParams] := FamS;
  FDQueryAddINDI.Params[12].AsIntegers[NumParams] := Linkinfo;
  FDQueryAddINDI.Params[13].AsIntegers[NumParams] := ToDo;
  FDQueryAddINDI.Params[14].AsIntegers[NumParams] := NextReportIndi;
  FDQueryAddINDI.Params[15].AsIntegers[NumParams] := FirstAncestralLoop;
  inc(NumParams);
until done;
FDQueryAddINDI.Params.ArraySize := NumParams;  { Reset to actual number }
 
FDQueryAddINDI.Execute(LogoAppForm.FDQueryAddINDI.Params.ArraySize);

 FDQueryAddINDI.Params.ParamValues['indikey;hasdata;gedcomnames;sex;birthdate;died;deathdate;changed;eventlinesneedprocessing;eventlines;famc;fams;linkinfo;todo;nextreportindi;firstancestralloop']
       := VarArrayOf([Indikey, 0, ' ', ' ', ' ', 0, ' ', ' ', 1, ' ', -1, -1, -1, -1, -1, -1]);

DataModule2.FDQuery1.Active := true;

procedure TDataModule2.DataModuleCreate(Sender: TObject);
begin
   path := ExtractFilePath(ParamStr(0));
   FDConnection1.Params.Add('Database='+path+'Database\dbm.db');
   FDConnection1.Connected := True;
end;

procedure TForm1.Button2Click(Sender: TObject);
var i : integer;
begin
       DataModule2.FDQuery1.SQL.Text := 'insert into data values ( :p1, :p2, :p3, :p4, :p5, :p6, :p7, :p8, :p9)';
       DataModule2.FDQuery1.Params.ArraySize := 10000;
      try
      for I := 0 to 10000 -1 do
       begin
          DataModule2.FDQuery1.Params[0].Asintegers[i] := i+1;
          DataModule2.FDQuery1.Params[1].AsStrings[i] := 'Ok';
          DataModule2.FDQuery1.Params[2].AsDateTimes[i] := now;
          DataModule2.FDQuery1.Params[3].AsFloats[i]:= double(i) + 0.1 ;
          DataModule2.FDQuery1.Params[4].AsFloats[i]:= double(i) + 0.1 * 0.2;
          DataModule2.FDQuery1.Params[5].AsFloats[i]:= double(i) + 0.1 * 3;
          DataModule2.FDQuery1.Params[6].AsFloats[i]:= 1.0;
          DataModule2.FDQuery1.Params[7].AsIntegers[i]:= i * 3;
          DataModule2.FDQuery1.Params[8].AsStrings[i]:= 'Title';
      end;
        DataModule2.FDQuery1.Params.ArraySize := i;
        DataModule2.FDQuery1.Execute(10000, 0);
        DataModule2.FDQuery1.Connection.Commit;
      except
      on e:Exception do
      begin
        DataModule2.FDQuery1.Connection.Rollback;
        raise;
      end;
      end;
end;