Перемещени курсора на цвет пикселя

[romka1608]

мне нужно когда я нажимаю Mouse1(НЕ ТОЛЬКО В ПРОГРАММЕ,а И НА РОБОЧЕМ СТОЛЕ ,к примеру),
то курсор перемещаеться на цвет пикселя пиксель


иСпользую этот код

procedure TForm1.Button3Click(Sender: TObject);
var
    hwnd:THandle;
    p:Tcolor;
    i,j:integer;
    bit:TBitmap;
    flag:boolean;
    pos:tpoint;
begin
flag:=false;   // флаг выхода из первого цикла
p:=rgb(183,187,185);
bit:=TBitmap.Create;
bit.Width := Screen.Width;
bit.Height := Screen.Height;
hwnd:=FindWindow(nil, 'имя окна');
BitBlt(bit.Canvas.Handle, 0, 0, Width, Height, GetDC(hwnd), 0, 0,SRCCOPY );
 
for i:=0 to bit.Width do begin
  for j:=0 to bit.Height do
    if bit.Canvas.Pixels[i,j]=p then begin
       flag:=true;
       break;
    end;
if flag then
  break;
end;

но после нажатие button всё зависает

[asmprog]

вопрос то в чем? виснет - а вы в фотошопе за какое время сможете цвет каждого пикселя проверить(тем более, что работа идет со снимком экрана, вроде как)?

[BDA]

procedure TForm1.Button1Click(Sender: TObject);
var
  p: Tcolor;
  i, j: integer;
  bit: TBitmap;
  flag: boolean;
  t: tdatetime;
begin
  flag := false;
  p := rgb(94, 168, 38);
  bit := TBitmap.Create;
  bit.Width := Screen.Width;
  bit.Height := Screen.Height;
  BitBlt(bit.Canvas.Handle, 0, 0, bit.Width, bit.Height, GetDC(0), 0, 0, SRCCOPY);

  t := now;
  for i := 0 to bit.Height - 1 do
  begin
    for j := 0 to bit.Width - 1 do
      if bit.Canvas.Pixels[j, i] = p then
      begin
        flag := true;
        break;
      end;
    if flag then
      break;
  end;
  caption := FormatDateTime('s.zzz', now - t);

  if flag then
    setcursorpos(j, i);

  bit.Free;
end;

1.4 секунды для "осмотра" экрана 1366 на 768.
Чтобы выполнять поиск по нажатию мыши, ищите "delphi mouse click hook" (пример).

[phomm]

TBitmap.ScanLine должен работать гораздо быстрее, чем TBitmap.Canvas.Pixels
Можно поискать примеры в разделе программирования игр.

[BDA]

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

TBitmap.ScanLine должен работать гораздо быстрее, чем TBitmap.Canvas.Pixels.

И правда. Вчера почему-то не дало выигрыша (2.6 секунды против 1.4 - наверное, где-нибудь "налажал").

0.004 секунды на экране 1366 на 768:

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j, dx: integer;
  bit: TBitmap;
  flag: boolean;
  t: tdatetime;
  Pixels: PByteArray;
const
  red1 = 94;
  green1 = 168;
  blue1 = 38;
begin
  flag := false;
  bit := TBitmap.Create;
  bit.PixelFormat := pf24bit;
  bit.Width := Screen.Width;
  bit.Height := Screen.Height;
  BitBlt(bit.Canvas.Handle, 0, 0, bit.Width, bit.Height, GetDC(0), 0, 0, SRCCOPY);

  t := now;
  dx := DWord(bit.ScanLine[1]) - DWord(bit.ScanLine[0]);
  Pixels := bit.ScanLine[0];
  for i := 0 to bit.Height - 1 do
  begin
    for j := 0 to bit.Width - 1 do
    begin
      flag := (Pixels[j * 3 + 2] = red1) and (Pixels[j * 3 + 1] = green1) and (Pixels[j * 3] = blue1);
      if flag then
        break;
    end;
    if flag then
      break;
    inc(DWord(Pixels), dx);
  end;
  caption := FormatDateTime('s.zzz', now - t);

  if flag then
    setcursorpos(j, i);

  bit.Free;
end;