Code that forces multiple threads to simultaneously write

procedure TConcurentWriterThread.Execute;
var F: TFileStream;
    StopTime: TDateTime;
    s: string;
    Buff: array[0..1024] of Byte;
    i: Integer;
begin
  try
    StopTime := Now + EncodeTime(0, 0, 30, 0);
    F := TFileStream.Create('C:\Temp\Proba.bin', fmOpenWrite or fmShareDenyNone);
    try
      while Now < StopTime do
      begin
        F.Position := Random(1000);
        for i:=0 to High(Buff) do
          Buff[i] := Random($ff);
        if F.Write(Buff, SizeOf(Buff)) <> SizeOf(Buff) then
          RaiseLastOSError;
      end;
    finally F.Free;
    end;

    Synchronize(
      procedure
      begin
        ShowMessage('Thread Done.');
      end
    );

  except on E:Exception do
    begin
      s := E.ClassName + ' / ' + E.Message;
      Synchronize(
        procedure
        begin
          ShowMessage(s);
        end
      );
    end;
  end;
end;

procedure TForm25.Button1Click(Sender: TObject);
var n:Integer;
begin
  for n:=1 to 4 do
    with TConcurentWriterThread.Create(True) do
    begin
      FreeOnTerminate := True;
      Start;
    end;
end;