Поток приостанавливается на 1-2 сек

[northener]

Читерство маст дай!

[stlcrash]

Сообщение от Pavia

1)Про потоки:
http://www.delphimaster.ru/articles/panov/index.html
2)Пауза в 2 секунды Sleep(2000)

3)Кладёшь на форму таймер. Задаёшь периуд. И проверяешь свои 5 переменных.
4)Чтобы разрушение побочного потока не влияло, на проверку. Переменные делаешь глобальными или кладёшь их класс основной формы.

А библиотеку с ресурсами (BMP файлы) подгружать отдельно в потоке? (используются в процедуре) или глобально ее объявить?

[stlcrash]

Что я делаю не так?
MonDirThread.MonDirTotem всегда выдает true
Не зависимо от того, что на экране.. Без потока все работало.
И во вторых, процедура checkall стала работать в потоке в несколько раз дольше, чем в основном потоке в старой версии программы.

В основном потоке:

procedure TForm1.FormCreate(Sender: TObject);
begin
  //поток
  MonDirThread:=TMonDirThread.Create(False);
  MonDirThread.FreeOnTerminate:=false;
  MonDirThread.Priority:=tpNormal;
end;

procedure TForm1.sButton9Click(Sender: TObject);
begin
 if MonDirThread.MonDirTotem then showmessage( 'нет тотема'+#13+InttoStr(MonDirThread.kol) ) else  showmessage( 'тотема'+#13+InttoStr(MonDirThread.kol) ) ;
end;

Код потока:

unit uMonThread;

interface

uses
  Forms,System.Classes, Windows, Messages, SysUtils, Variants, Graphics, Controls, Dialogs, ExtCtrls, StdCtrls, ComCtrls, mmsystem;

  type FResMonDir = record found: boolean; x,y: integer; end;

   type
  //Для сравнения изображений (чб)
  pRGBLineMonDir=^TRGBLineMonDir;
  TRGBLineMonDir=array[word] of RGBTriple;
  TIMGDataMonDir=array[word] of pRGBLineMonDir;

type
  TMonDirThread = class(TThread)
  private
    procedure checkall();
    Procedure BrowserScreen(imgW,imgH,X,Y,BlackToWhite:integer;BMP:TBitmap);
    procedure Threshold(Bitmap: TBitmap; Value: Byte; Color1, Color2: TColor);
    Procedure BMPFromDLL(bmp:TBitmap; ResName: string;BlackToWhite:integer);
    function CompareIMG(bmp1, bmp2:TBitMap): FResMonDir;
    function ResName(Monster:string): string;
  public

  next:boolean;              //Для остановки процесса
  kol:integer;

  MonDirHello,       //здороваемся
  MonDirLS,          //ЛС
  MonDirGiExit,      //Игрок покинул гильдию
  MonDirInviteClose, //Отклонять приглашения в группы
  MonDirExitParty,   //Отряд расформирован
  MonDirDied,        //если умер
  MonDirParalich,    //контроль паралича
  MonDirMorf,        //контроль перевоплощения
  MonDirMorfSec,     //контроль перевоплощения(почти закончился)
  MonDirTotem,       //тотем
  MonDirRampage,     //проверка на буйство
  MonDirTimeValk,    //проверка на искажение времени
  MonDirSpeed,       //проверка на скорость
  MonDirDisconnect   //Дисконнект
  :boolean;

    var
    nick:string;
    { Private declarations }

  protected
    procedure Execute; override;
  end;

  var
  AModule: THandle;
  maxerr:integer;


implementation

procedure TMonDirThread.BMPFromDLL(bmp: TBitmap; ResName: string;
  BlackToWhite: integer);
begin
    bmp.LoadFromResourceName(AModule,ResName);
    if BlackToWhite<>900 then Threshold(bmp, BlackToWhite, clWhite, clBlack);
end;

procedure TMonDirThread.BrowserScreen(imgW, imgH, X, Y, BlackToWhite: integer;
  BMP: TBitmap);
var
  vDesktopDC: HDC;
begin
  vDesktopDC := GetWindowDC(GetDesktopWindow);
  try
      bmp.PixelFormat := pf24bit;
      bmp.Height := Screen.Height;
      bmp.Width := Screen.Width;
      BitBlt(bmp.Canvas.Handle, 0,0,imgW,imgH,vDesktopDC,X,Y,SRCCOPY);
      if BlackToWhite<>900 then Threshold(bmp,BlackToWhite,clWhite, clBlack);
  finally
    ReleaseDC(GetDesktopWindow, vDesktopDC);
end;
//  application.ProcessMessages;
end;

procedure TMonDirThread.checkall;
var
  FindResult: FResMonDir;
  s:string;
  HelloChekerBMP1,HelloChekerBMP2:TBitmap;
begin
  HelloChekerBMP1:=TBitmap.Create;
  HelloChekerBMP2:=TBitmap.Create;

//здороваемся
  begin
    BrowserScreen(200,12,20, 644, 165, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'hi',165);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then
        begin
          BrowserScreen(200,12,20, 644, 250, HelloChekerBMP1);
          BMPFromDLL(HelloChekerBMP2,ResName(nick),250);
          FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
           if not FindResult.found then MonDirHello:=true else MonDirHello:=false;
        end;
  end;

  //ЛС
  begin
    BrowserScreen(70,13,15, 644, 160, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'ls',160);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then MonDirLS:=true else MonDirLS:=false;
  end;

  //Игрок покинул гильдию
  begin
    BrowserScreen(160,10,650, 410, 250, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'gildia',250);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then MonDirGiExit:=true else MonDirGiExit:=false;
  end;

  //Отклонять приглашения в группы
  begin
    BrowserScreen(160,10,630, 360, 250, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'InviteClose',250);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then MonDirInviteClose:=true else MonDirInviteClose:=false;
  end;

  //Отряд расформирован
  begin
    BrowserScreen(110,15,585, 365, 250, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'group',250);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then MonDirExitParty:=true else MonDirExitParty:=false;
  end;

  //если умер
  begin
    BrowserScreen(40,10,540, 340, 250, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'died',250);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if FindResult.found then MonDirDied:=true else MonDirDied:=false;
  end;

  //контроль паралича
    begin
      BrowserScreen(303,35,970, 60, 120, HelloChekerBMP1);
      BMPFromDLL(HelloChekerBMP2,'paralich',120);
      FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
      if FindResult.found then MonDirParalich:=true else MonDirParalich:=false;
    end;

  //контроль перевоплощения
  begin
    BrowserScreen(600,32,676, 12, 200, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'voplot',200);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then  MonDirMorf:=false else begin
      MonDirMorf:=true;
      BrowserScreen(50,10,676+FindResult.x-12, 12+FindResult.y+35, 250, HelloChekerBMP1);
      BMPFromDLL(HelloChekerBMP2,'voplottime',250);
      FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
      if FindResult.found then MonDirMorfSec:=true else MonDirMorfSec:=false;
    end;
  end;

[stlcrash]

//тотем
  begin
    BrowserScreen(600,32,676, 12, 220, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'totem',220);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then MonDirTotem:=true else MonDirTotem:=false;
  end;

    //проверка на буйство
  begin
    BrowserScreen(600,32,676, 12, 120, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'rampage1',120);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then MonDirRampage:=true else MonDirRampage:=false;
  end;

  //проверка на искажение времени
  begin
    BrowserScreen(600,32,676, 12, 220, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'timevalk',220);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then MonDirTimeValk:=true else MonDirTimeValk:=false;
  end;

  //проверка на скорость
  begin
    BrowserScreen(600,32,676, 12, 180, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,'speed',180);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then  MonDirSpeed:=true else  MonDirSpeed:=false;
  end;

  //Дисконнект
  begin
    s:='discinnect';
    BrowserScreen(90,10,650, 410, 250, HelloChekerBMP1);
    BMPFromDLL(HelloChekerBMP2,s,250);
    FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    if not FindResult.found then
    begin
      s:='discinnect1';
      BMPFromDLL(HelloChekerBMP2,s,250);
      FindResult:=CompareIMG(HelloChekerBMP1,HelloChekerBMP2);
    end;
    if FindResult.found then  MonDirDisconnect:=true else  MonDirDisconnect:=false
  end;
  HelloChekerBMP1.Free;
  HelloChekerBMP2.Free;
end;

function TMonDirThread.CompareIMG(bmp1, bmp2: TBitMap): FResMonDir;
var
  i,y, x, yy, xx, err: integer;
  IMG1,IMG2: TIMGDataMonDir;
begin
  for i:=0 to bmp1.Height-1 do IMG1[i]:=bmp1.ScanLine[i];
  for i:=0 to bmp2.Height-1 do IMG2[i]:=bmp2.ScanLine[i];
  //основной цикл по всему изображению
  y:=0;
  repeat
    x:=0;
    repeat
      //вложеный цикл по искомому фрагменту
      Result.found:=true;
      yy:=0;
      repeat
        xx:=0;
        repeat
          //если нужно точное соответствие достаточно проверить только одну компоненту
          if maxerr=0 then begin

            if IMG1[y+yy, x+xx].rgbtGreen<>IMG2[yy,xx].rgbtGreen then Result.found:=false;
          //в противном случае сначала считаем ошибку (сумму абсолютных разниц)
          end else begin
            err:=abs(IMG1[y+yy, x+xx].rgbtBlue - IMG2[yy,xx].rgbtBlue)+
                 abs(IMG1[y+yy, x+xx].rgbtGreen - IMG2[yy,xx].rgbtGreen)+
                 abs(IMG1[y+yy, x+xx].rgbtRed - IMG2[yy,xx].rgbtRed);
            //если ошибка больше допустимой, сбрасываем флаг, дальше просматривать фрагмент нету смысла
            if err>maxerr then Result.found:=false;
          end;
          inc(xx);
        until (xx>=bmp2.Width) or (Not Result.found);
        inc(yy);
      until (yy>=bmp2.Height) or (Not Result.found);
      inc(x);
    until (x>bmp1.Width-bmp2.Width) or (Result.found);
    inc(y);
  until (y>bmp1.Height-bmp2.Height) or (Result.found);
  //если флаг установлен, значит есть результат, записываем координаты верхнего левого пиксела
  if Result.found then begin
    Result.x:=x-1;
    Result.y:=y-1;
  end;
end;

procedure TMonDirThread.Execute;
begin
  { Place thread code here }
  maxerr:=0;
  AModule := LoadLibrary('res.dll');
  next:=true;

  MonDirHello:=false;       //здороваемся
  MonDirLS:=false;          //ЛС
  MonDirGiExit:=false;      //Игрок покинул гильдию
  MonDirInviteClose:=false; //Отклонять приглашения в группы
  MonDirExitParty:=false;   //Отряд расформирован
  MonDirDied:=false;        //если умер
  MonDirParalich:=false;    //контроль паралича
  MonDirMorf:=false;        //контроль перевоплощения
  MonDirMorfSec:=false;     //контроль перевоплощения(почти закончился)
  MonDirTotem:=false;       //('тотем');
  MonDirRampage:=false;     //проверка на буйство
  MonDirTimeValk:=false;    //проверка на искажение времени
  MonDirSpeed:=false;       //проверка на скорость
  MonDirDisconnect:=false;   //Дисконнект

  kol:=0;

  while next do
  begin

    kol:=kol+1;
    checkall;


  end;

  FreeLibrary(AModule);
end;

function TMonDirThread.ResName(Monster: string): string;
begin
  if Monster='Гоблин-шахтер' then begin result:='goblinshacter'; exit; end;
  if Monster='Ящер огня' then begin result:='yasherogna'; exit; end;
  if Monster='Мантикора' then begin result:='manticora'; exit; end;
  if Monster='Дикарь' then begin result:='dicar'; exit; end;
  if Monster='Камень чакры' then begin result:='chacra'; exit; end;
  if Monster='Слизь' then begin result:='sliz'; exit; end;
  if Monster='Рак-отшельник' then begin result:='rakotshel'; exit; end;
  if Monster='Личинка' then begin result:='lichinka'; exit; end;

  if Monster='Внешний лагерь' then begin result:='homeHM'; exit; end;
  if Monster='Дом Гильдии' then begin result:='home'; exit; end;
  if Monster='Деревня Эшборн' then begin result:='eshborn'; exit; end;
  if Monster='Деревня Байрон' then begin result:='bairon'; exit; end;
  if Monster='Деревня Роден' then begin result:='roden'; exit; end;
  if Monster='Деревня Темных земель' then begin result:='darkearth'; exit; end;
  if Monster='Арена Гильдий' then begin result:='arena'; exit; end;

  if Monster='Сум основа' then begin result:='crash'; exit; end;
  if Monster='Сум твинк' then begin result:='crash1'; exit; end;
  if Monster='Маг' then begin result:='nick'; exit; end;
end;

procedure TMonDirThread.Threshold(Bitmap: TBitmap; Value: Byte; Color1,
  Color2: TColor);
type TRGB = record B, G, R: Byte; end; pRGB = ^TRGB;
function ColorToRGB(Color: TColor): TRGB;
  begin
  with Result do
    begin
      R := Lo(Color);
      G := Lo(Color shr 8);
      B := Lo((Color shr 8) shr 8);
    end;
  end;
var x, y: Word; C1, C2: TRGB; Dest: pRGB;
begin
Bitmap.PixelFormat := pf24Bit;
C1 := ColorToRGB(Color1);
C2 := ColorToRGB(Color2);
for y := 0 to Bitmap.Height - 1 do
  begin
    Dest := Bitmap.ScanLine[y];
    for x := 0 to Bitmap.Width - 1 do
      begin
        if (Dest^.r + Dest^.g + Dest^.b) / 3 > Value then Dest^ := C1 else Dest^ := C2; Inc(Dest);
      end;
  end;
end;


end.

[stlcrash]

Причину проблемы нашел
Некорректно работает процедура

procedure TMonDirThread.BrowserScreen(imgW, imgH, X, Y, BlackToWhite: integer;
  BMP: TBitmap);
var
  vDesktopDC: HDC;
begin
  vDesktopDC := GetWindowDC(GetDesktopWindow);
  try
      bmp.PixelFormat := pf24bit;
      bmp.Height := imgH;
      bmp.Width :=imgW;
      BitBlt(bmp.Canvas.Handle, 0,0,imgW,imgH,vDesktopDC,X,Y,SRCCOPY);
      if BlackToWhite<>900 then Threshold(bmp,BlackToWhite,clWhite, clBlack);
  finally
    ReleaseDC(GetDesktopWindow, vDesktopDC);
end;
  application.ProcessMessages;
end;

из потока. В основном потоке с ней все ок. Но из побочного потока эта же процедура делает нимок непонятно чего. Как ее исправить, чтоб работала в потоке?

[stlcrash]

В общем разобрался как работать с дебаг режимом в делфи ХЕ8 и сразу нашел в чем причина и головная боль..
Везде перед скриншотами натыкал и заработало.

       
HelloChekerBMP1.Free;
HelloChekerBMP2.Free;
HelloChekerBMP1:=TBitmap.Create;
HelloChekerBMP2:=TBitmap.Create;