Добрый день, уважаемые пользователи.
Суть проблемы: При запуске процедуры идет работа в файле размеров в .... мегабайт. И после 5 секунд выскакивает окно out of memory. Хотя файлы до 200 мегабайт нормально.
procedure Tfrm_Main.Run;
var afList: TStringDynArray;
i, j, k: integer;
L, rL, fL: TStringList;
NewName, tmp: String;
begin
memo_Log.Lines.Add(Format('Начало обработки: %s', [DateTimeToStr(Now)]));
memo_Log.Lines.Add('///');
memo_Log.Lines.Add('');
L := TStringList.Create;
for i := 0 to memo_Folders.Lines.Count - 1 do
begin
afList := TDirectory.GetFiles(memo_Folders.Lines[i], '*.txt', SO);
for j := 0 to Length(afList) - 1 do
L.Add(afList[j]);
end;
rL := TStringList.Create;
rL.Text := Trim(memo_List.Text);
k := 0;
fL := TStringList.Create;
for i := 0 to L.Count - 1 do
begin
memo_Log.Lines.Add(Format('Обработка файлов %s', [L.Strings[i]]));
fL.LoadFromFile(L.Strings[i]);
tmp := ExtractFileName(L.Strings[i]);
tmp := Copy(tmp, 1, Pos('.', tmp) - 1);
NewName := Format('%s%s.%s', [ExtractFilePath(L.Strings[i]),
tmp,
FormatDateTime('ddmmyy_hhnn', Now)]);
if rg_Order.ItemIndex = 1 then
for j := 0 to rL.Count - 1 do
rL.Exchange(j, RandomRange(0, rL.Count));
for j := 0 to fL.Count - 1 do
begin
fL.Strings[j] := StringReplace(fL.Strings[j], edt_Word.Text, rL.Strings[k], RF);
inc(k);
if k = rL.Count then k := 0;
end;
fL.SaveToFile(NewName);
memo_Log.Lines.Add(Format('Сохранение под именем %s', [NewName]));
memo_Log.Lines.Add('');
end;
memo_Log.Lines.Add('///');
memo_Log.Lines.Add(Format('Окончание обработки: %s', [DateTimeToStr(Now)]));
fL.Free;
rL.Free;
L.Free;
btn_Next.Enabled := false;
LoadBMP(btn_Prev, 5);
btn_Prev.Caption := 'С начала';
end;
Ответ
Это не утечка. TStringList имеет ограничение на работу с очень большими файлами (учитывая, что размер файла в памяти после загрузки увеличится вдвое). Как раз 5-10 секунд проходит до того момента, как он упирается в него.
Используйте либо классический readln, либо перерабатывайте под себя TFileStream. Вот пример, давно использованный в нашей программе для работы с большими текстами, переработайте его под себя:
type
TTextFileStream = class(TFileStream)
private
FBuffer: string;
public
function Eof: Boolean;
procedure WriteLn(Text: string);
function ReadLn: string;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
function RowsCount: Integer;
end;
implementation
{ TTextFileStream }
function TTextFileStream.Eof: Boolean;
begin
Eof := ((Position - Length(FBuffer)) = Size);
end;
function TTextFileStream.ReadLn: string;
const
BufferLength = 10000;
var
NewBuffer: string;
Readed: Integer;
begin
Readed := 1;
while (Pos(#13, FBuffer) = 0) and (Readed > 0) do begin
SetLength(NewBuffer, BufferLength + 2);
Readed := Read(NewBuffer[1], BufferLength);
SetLength(NewBuffer, Readed);
FBuffer := FBuffer + NewBuffer;
end;
if Pos(#13, FBuffer) > 0 then begin
Result := Copy(FBuffer, 1, Pos(#13, FBuffer) - 1);
Delete(FBuffer, 1, Pos(#13, FBuffer) + 1);
end else begin
Result := FBuffer;
FBuffer := '';
end;
end;
function TTextFileStream.RowsCount: Integer;
begin
Result := 1;
FBuffer := '';
Seek(0, soBeginning);
while not Eof do begin
ReadLn;
Inc(Result);
end;
Seek(0, soBeginning);
end;
function TTextFileStream.Seek(const Offset: Int64;
Origin: TSeekOrigin): Int64;
begin
if Origin = soCurrent then
Result := inherited Seek(Offset - Length(FBuffer), Origin)
else Result := inherited Seek(Offset, Origin);
FBuffer := '';
end;
procedure TTextFileStream.WriteLn(Text: string);
const
NewLine = #13#10;
begin
Seek(0, soCurrent);
Write(Text[1], Length(Text));
Write(NewLine, 2);
end;
Комментариев нет:
Отправить комментарий