[Creator13]

Доброго времени суток, уважаемые программисты.
Пишу программку - анализатор картинок.

На форме есть таймер с интервалом времени в 1с
Каждую секунду таймер делает скриншот экрана и анализирует полученную картинку
Ищутся определенные вхождения на скрине и сравниваются с Image'ами, которые просто лежат на форме с загруженными картинками Если находит вхождение - заносятся данные в Edit'ы и Lable'ы
Все бы хорошо. Программа работает на отлично около часа-полтора, а потом начинаются зависоны...
В конечном итоге табличка "out of sysyem resource" и все встает... Иногда прогу вышибает(сама закрывается)
Хотя никаких завершений в Timer1 не прописано и работает только он один. В нем только циклический скрин и сравнения.
По диспетчеру задач смотрю программа стабильно по-немногу, набирает память..
Хотя по идем должна быть "очистка" и обнуление буфера,если я правильно понимаю. Помогите пожалуйста.

Ниже код:

Код:

uses
  Windows.....;

type
    FRes = record
    found: boolean;
    x,y: integer;

  private
    { Private declarations }
  public
    { Public declarations }
  end;
     TBuf = array of array of integer;

var
  FindResult: FRes;
  buf1, buf2: TBuf;

procedure ScreenShot(var buffer: TBuf; img: TImage);
var
  x,y,c: integer;
  p: pByteArray;
  bmp:TBitmap;
begin
    bmp := TBitmap.Create;
    bmp.Width := Screen.Width;
    bmp.Height := Screen.Height;;
    BitBlt(bmp.Canvas.Handle, 0,0, Screen.Width, Screen.Height,GetDC(0), 0,0,SRCCOPY);
    img.Picture.Assign(bmp);
    img.Picture.Bitmap.PixelFormat:=pf24Bit;
    SetLength(buffer, img.Height, img.Width);
    for y:=0 to img.Height-1 do begin
    p:=img.Picture.Bitmap.ScanLine[y];
    for x:=0 to img.Width-1 do begin
     c:=((p[x*3+0] shl 8+p[x*3+1]) shl 8)+p[x*3+2];
     buffer[y,x]:=c;
    end;
  end;
    bmp.Free;
end;

procedure ReadIMG(var buffer: TBuf; img: TImage);
var
  x,y,c: integer;
  p: pByteArray;
begin
  img.Picture.Bitmap.PixelFormat:=pf24Bit; // pf8Bit;
  SetLength(buffer, img.Height, img.Width);
  for y:=0 to img.Height-1 do begin
    p:=img.Picture.Bitmap.ScanLine[y];
    for x:=0 to img.Width-1 do begin
      c:=((p[x*3+0] shl 8+p[x*3+1]) shl 8)+p[x*3+2];
      buffer[y,x]:=c;
    end;
  end;
end;

function CompareIMGS(Im1:TImage; Im2:TImage): FRes;
var
  y, x, yy, xx: integer;
begin
  ReadIMG(buf2,Im2);
  y:=0;
  repeat
    x:=0;
    repeat
      Result.found:=true;
      yy:=0;
      repeat
        xx:=0;
        repeat
          if buf1[y+yy, x+xx]<>buf2[yy,xx] then Result.found:=false;
          inc(xx);
        until (xx>=Im2.Width) or (Not Result.found);
        inc(yy);
      until (yy>=Im2.Height) or (Not Result.found);
      inc(x);
    until (x>Im1.Width-Im2.Width) or (Result.found);
    inc(y);
  until (y>Im1.Height-Im2.Height) or (Result.found);
  if Result.found then begin
    Result.x:=x-1;
    Result.y:=y-1;
  end;
end;

procedure TForm1.T_FightTimer(Sender: TObject);
begin
 ScreenShot(buf1,Image_ScreenShot);  //скриншот
 
 FindResult:=CompareIMGS(Image_ScreenShot,I_apple); //имейдж apple загруженный лежит на форме
 if FindResult.found then edit1.text:='У Вас яблоко!';

 // тут ... ниже, вот таких последних двух строчек сравнений, в теле таймера, порядка 25 штук (25 сравнений) 

end;

Спасибо!

[Alegun]

25 штук за 1с? Оригинально :-) Может просто не успевает отрабатывать таймер и циклится повторно? Поробуйте в начале процедуры таймер отключать, а в конце снова его запускать.

[Creator13]

Да 25 сравнений. На удивление все быстро и отлично работает и сравнивает... Только трабл с ресурсами после часа, полтора работы

[Alegun]

Собрал на D7 и прогнал под W7 этот код (http://zalil.ru/34729896) в течении несколько часов - утечка была из-за массивов типа TBuf, может и не правильно это, но помогло обнуление в конце выполнения функции CompareIMGS массивов buf1 и buf2.

[Creator13]

Опаа.... Огроменное тебе спасибо.

Нашел ссылочку сейчас скачаю.

[Alegun]

Утечки по 4к за цикл прекратились, во всяком случае за 3 часа работы больше 7Мб сборка так и не слопала.

[Creator13]

Поставил в конце функции CompareIMGS как посоветовал.
SetLength(buf1, 1, 1);
SetLength(buf2, 1, 1);

Вылез Exeption. Видимо после 1го сравнения буфер пропал а на втором следующем в таймере сравнении уже он его не нашел.

Поставил такое зануление в конце всех сравнений в таймере

procedure TForm1.TTimer1(Sender: TObject);
begin
//......................CompareIMGS
//............CompareIMGS
//...

SetLength(buf1, 1, 1);
SetLength(buf2, 1, 1)
end;

Сейчас буду тестить...
Или при этом способе тоже будет утекать?