procedure TForm1.BitBtn1Click(Sender: TObject);
type
  TDDA = array[1..362881,1..9] of shortint;
var
M,N: shortint;
ii,iii: integer;
i,j,jj,jjj: integer;
S: integer;
x,y: integer;
z,del: shortint;
seed: integer;
a: ^TDDA;
MM,M1: integer;

begin

M:=StrToInt(Edit1.Text);
Label1.Caption:= 'Всего комбинаций: ' + FloatToStr(Fac(M));
StartTime := GetTickCount;
GetMem(a,(Fac(M)+1)*(M+1)*4);

// Очистка главной матрици
for ii:=1 to Fac(M) do
  for iii:=1 to M do
    a^[ii,iii]:=0;

ListBox1.Items.Clear;
ListBox1.Items.BeginUpdate;

{Indikator:=TIndikator.Create(Self);
Indikator.ProgressBar1.Max:=Fac(M);
Indikator.Show;
Indikator.Update;}


// Начало цикла
for N:=1 to M do
  begin

  // Долбавление к массиву а столбец N!*1 справа.
  for i:=1 to Fac(N) do
      a^[i,N]:=N;

  // Копирование и сортировка
  for jj:=1 to Fac(N) do
    begin
    z:=(jj-1) div Fac(N-1);
    for jjj:=1 to (N-1) do
      begin
      a^[jj,jjj]:=a^[jj-z*Fac(N-1),jjj]
      end;
    {Сортировка}
    {if N=M then
      begin
      Indikator.ProgressBar1.StepIt;
      Indikator.Update;
      end;}
    del:= (jj-1) div Fac(N-1);
    seed:= a[jj,N-del];
    a^[jj,N-del]:= a^[jj,N];
    a^[jj,N]:=seed;
    end;
 end;


// Вывод конечного массива на экран
  for x:=1 to Fac(M) do
    begin
    S:=0;
    for y:=1 to M do
      begin
      S:=S + a^[x,y]*Trunc(exp((M-y)*Ln(10)))
      end;
    //b^[x]:=S;
    ListBox1.Items.Strings[x-1]:= FloatToStr(s){ + '  [' + FloatToStr(x)+ ']'};
    end;

//Indikator.Hide;
//Indikator.Free;

FreeMem(a,(Fac(M)+1)*(M+1)*4);

sek := (GetTickCount - StartTime) div 1000;
min:= sek div 60;
hour:= min div 60;
if sek<=60 then
  Label4.Caption:='Время работы = ' + FloatToStr(sek) + ' сек.'
else if sek>60 then
 Label4.Caption:='Время работы= ' + FloatToStr(min)+'мин '
 + FloatToStr(sek-60*min) + 'сек'
else if hour>=1 then
  Label4.Caption:='Время работы= ' + FloatToStr(hour) + 'ч '
  + FloatToStr(min)+'мин ' + FloatToStr(sek-60*min) + 'сек';

ListBox1.Items.EndUpdate;

end;

unit RandomCalc;

Type
 TResultForm = class(TForm)
  ProgressBar: TProgresBar;
  StartButton: TButton;
  procedure FormCreate(Sender: TObject);
  procedure StartButtonClick(Sender: TObject);
 private
  f_ThreadID: DWORD;
  f_ProgressPosition,
  f_ProgressMax:  Longint;
 public
  procedure ApplicationIdle(Sender: TObject);
 
 end;

{
 Класс TThread идет лесом - он тормозной, т.к.
 имеет оконный хэндл и процессит сообщения.
 Используем API-шные функции.
}
function CalcThreadProc(ThreadData: Pointer): DWORD; stdcall;
var
 aForm:  TResultForm;
begin
 aForm := TResultForm(ThreadData);
 { Поехали, Вычисляем кол-во итераций }
 aForm.f_ProgressMax := Кол-во_итераций;
 { Вычисляем }
 aForm.ProgressPosition := Номер_итерации:
 { Закончили вычисления }
 aForm.f_ThreadID := 0;
 Application.OnIdle := nil;
end;

procedure TResultForm.StartButtonClick(Sender: TObject);
begin
 if f_ThreadID <> 0 then Exit; // Уже идет вычисление!!!
 if CreateThread(nil,8192,@CalcThreadProc,Pointer(Self),CREATE_SUSPENDED,f_ThreadID) = 0 then
   MessageBox(Handle,'Облом при создании потока для вычислений','Серьезная ошибка',MB_OK OR MB_ICONHAND)
 else begin
  SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_BELOW_NORMAL);
  SetThreadPriority(f_ThreadID,THREAD_PRIORITY_TIME_CRITICAL);   
  f_ProgressMax := 0;
  f_ProgressPosition := 0;
  ResumeThread(f_ThreadID);
  Application.OnIdle =  ApplicationIdle;
 end;
end;

procedure TResultForm.FormCreate(Sender: TObject);
begin
 f_ThreadID := 0;
end;

procedure TResultForm.ApplicationIdle(Sender: TObject);
begin
 { Да плевать на присвоение, все равно эта зверюга не будет тормозить
   процесс }
 if f_ProgressMax = 0 then Exit;
 ProgressBar.Max := f_ProgressMax;
 ProgressBar.Position := f_ProgressPosition;
end;

var
 pi : TProcessInformation;
 si : TStartupInfo; 
 
begin
 ZeroMemory(@si,sizeof(si));
 si.cb:=SizeOf(si); 
 if not CreateProcess( PChar(lpApplicationName), //pointer to name of executable module 
 PChar(lpCommandLine), // Command line. 
 nil, // Process handle not inheritable.
 nil, // Thread handle not inheritable. 
 False, // Set handle inheritance to FALSE.   
 0, // No creation flags. 
 nil, // Use parent's environment block. 
 nil, // Use parent's starting directory.   
 si, // Pointer to STARTUPINFO structure.
 pi ) // Pointer to PROCESS_INFORMATION structure.   
 
 then begin   
 Result:=false;
 RaiseLastWin32Error; 
 Exit; 
 
 end; 
 
 while WaitforSingleObject(PI.hProcess,200)=WAIT_TIMEOUT do   application.ProcessMessages;
 CloseHandle(pi.hProcess); 
 CloseHandle(pi.hThread);
 
 // ... здесь твой код 
 
end;