Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Мультимедиа в Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 15.04.2016, 18:16   #1
OneMen
 
Регистрация: 15.04.2016
Сообщений: 3
По умолчанию Поиск изображения на экране.

Перепробовал кучу вариантов. В итоге максимум что вышло это поиск одного маленького изображения в другом большом изображении. В идеале нужен код который делает снимок экрана и ищет в нем заранее подготовленное изображение и выдающий координаты центра найденного на экране изображения. Пожалуйста помогите)

Код который ищет одно изображение в другом:
Код:
unit Main;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtDlgs, ExtCtrls, XPMan;
 
type
  FRes = record
    found: boolean;
    x,y: integer;
  end;
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    ScrollBox2: TScrollBox;
    Image1: TImage;
    Image2: TImage;
    OpenPictureDialog1: TOpenPictureDialog;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    XPManifest1: TXPManifest;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function CompareIMG: FRes;
  end;
  TBuf = array of array of integer;
 
var
  Form1: TForm1;
  buf1, buf2: TBuf;
 
implementation
 
{$R *.dfm}
 
procedure LoagIMG(var buffer: TBuf; img: TImage; Name: String);
var
  x,y,c: integer;
  p: pByteArray;
begin
  img.Picture.LoadFromFile(Name);
  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;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenPictureDialog1.Execute then
    LoagIMG(buf1, Image1, OpenPictureDialog1.FileName);
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  if OpenPictureDialog1.Execute then
    LoagIMG(buf2, Image2, OpenPictureDialog1.FileName);
end;
 
function TForm1.CompareIMG: FRes;
var
  y, x, yy, xx: integer;
begin
  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>=Image2.Width) or (Not Result.found);
        inc(yy);
      until (yy>=Image2.Height) or (Not Result.found);
      inc(x);
    until (x>Image1.Width-Image2.Width) or (Result.found);
    inc(y);
  until (y>Image1.Height-Image2.Height) or (Result.found);
  if Result.found then begin
    Result.x:=x-1;
    Result.y:=y-1;
  end;
end;
 
procedure TForm1.Button3Click(Sender: TObject);
var
  FindResult: FRes;
  SearchTime: cardinal;
  Freq, StartCount, EndCount: int64;
  HiResTimer: boolean;
begin
  if (Image1.Width<Image2.Width) or (Image1.Height<Image2.Height) then
    ShowMessage('Ошибка! Img1 меньше Img2')
  else begin
    Screen.Cursor:=crHourGlass;
    HiResTimer:=QueryPerformanceFrequency(Freq);
    if HiResTimer then QueryPerformanceCounter(StartCount) else SearchTime:=GetTickCount;
    FindResult:=CompareIMG;
    if HiResTimer then begin
      QueryPerformanceCounter(EndCount);
      SearchTime:=round((EndCount-StartCount)*1000/Freq);
    end else SearchTime:=GetTickCount-SearchTime;
    Screen.Cursor:=crDefault;
    if FindResult.found then begin
      with Image1.Picture.Bitmap.Canvas do begin
        Pen.Color:=clRed;
        MoveTo(FindResult.x, FindResult.y);
        LineTo(FindResult.x+Image2.Width-1, FindResult.y);
        LineTo(FindResult.x+Image2.Width-1, FindResult.y+Image2.Height-1);
        LineTo(FindResult.x, FindResult.y+Image2.Height-1);
        LineTo(FindResult.x, FindResult.y);
      end;
      ScrollBox1.HorzScrollBar.Position:=FindResult.x;
      ScrollBox1.VertScrollBar.Position:=FindResult.y;
      ShowMessage('Есть совпадение ;-)'+#10#13+'Время поиска: '+IntToStr(SearchTime)+' ms');
    end else ShowMessage('Нет совпадений!');
  end;
end;
 
end.
 
end.
OneMen вне форума Ответить с цитированием
Старый 15.04.2016, 18:58   #2
min@y™
Цифровой кот
Старожил
 
Аватар для min@y™
 
Регистрация: 29.08.2014
Сообщений: 7,656
По умолчанию

Код:
procedure LoagIMG(var buffer: TBuf; img: TImage; Name: String);
var
  x,y,c: integer;
  p: pByteArray;
begin
  img.Picture.LoadFromFile(Name);
  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;
Сразу узнаётся рука мастера, растущая из жопы мастера.
С прошлого раза, как я погляжу, ты и не понял, как работает scanline[].
Расскажу я вам, дружочки, как выращивать грибочки: нужно в поле утром рано сдвинуть два куска урана...
min@y™ вне форума Ответить с цитированием
Старый 15.04.2016, 23:29   #3
OneMen
 
Регистрация: 15.04.2016
Сообщений: 3
Вопрос

С прошлого раза? Я на этом форуме первый день. И да, я еще не понял как работает сканлайн т.к. столкнулся с ним впервые. И этот код не я писал, нашел его на форуме.

Проблема в том что код работает, но суть в том что первое изображение на котором надо искать второе должно делаться на месте, т.е. нужен скрин экрана и я никак не могу прикрутить туда битмап (а это единственный известный мне способ сделать скрин экрана). Если можете помочь буду благодарен.
OneMen вне форума Ответить с цитированием
Старый 15.04.2016, 23:47   #4
kropotkina-alice
Форумчанин
 
Аватар для kropotkina-alice
 
Регистрация: 27.10.2014
Сообщений: 594
По умолчанию

Цитата:
Сообщение от OneMen Посмотреть сообщение
нужен скрин экрана и я никак не могу прикрутить туда битмап (а это единственный известный мне способ сделать скрин экрана)
В свое время камрад maxionans предложил очень краткую реализацию снятия копии изображения на экране:
Код:
var
  DC : HDC;
  Bmp : TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    DC := GetDC( 0 );
    Bmp.SetSize( 100, 100 );
    BitBlt( Bmp.Canvas.Handle, 0, 0, 100, 100, DC, 0, 0, SRCCOPY );
    Bmp.SaveToFile( 'c:\test.bmp' );
    ReleaseDC( 0, DC );
  finally
    Bmp.Free;
  end;
end;
Обратите внимание, что тут "фотографируется" кусок экрана 100х100 в верхнем левом углу...

Последний раз редактировалось kropotkina-alice; 15.04.2016 в 23:49.
kropotkina-alice вне форума Ответить с цитированием
Старый 15.04.2016, 23:52   #5
min@y™
Цифровой кот
Старожил
 
Аватар для min@y™
 
Регистрация: 29.08.2014
Сообщений: 7,656
По умолчанию

Цитата:
И этот код не я писал, нашел его на форуме.
я узнал код по этому фрагменту:
Код:
c:=((p[x*3+0] shl 8+p[x*3+1]) shl 8)+p[x*3+2];
buffer[y,x]:=c;
Расскажу я вам, дружочки, как выращивать грибочки: нужно в поле утром рано сдвинуть два куска урана...
min@y™ вне форума Ответить с цитированием
Старый 16.04.2016, 00:10   #6
OneMen
 
Регистрация: 15.04.2016
Сообщений: 3
По умолчанию

Цитата:
Сообщение от kropotkina-alice Посмотреть сообщение
В свое время камрад maxionans предложил очень краткую реализацию снятия копии изображения на экране:
Код:
var
  DC : HDC;
  Bmp : TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    DC := GetDC( 0 );
    Bmp.SetSize( 100, 100 );
    BitBlt( Bmp.Canvas.Handle, 0, 0, 100, 100, DC, 0, 0, SRCCOPY );
    Bmp.SaveToFile( 'c:\test.bmp' );
    ReleaseDC( 0, DC );
  finally
    Bmp.Free;
  end;
end;
Обратите внимание, что тут "фотографируется" кусок экрана 100х100 в верхнем левом углу...
Вот как раз этот вариант мне и известен) Пытался прикрутить его к коду выше, но тогда программа не находит изображение. Пытался даже сначала сохранить в файл .bmp, а уже потом загружать его в программу, все равно не находит.
OneMen вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поиск цвета на экране egorka2134 Общие вопросы Delphi 6 25.02.2014 22:14
Поиск изображения на экране bmp Мультимедиа в Delphi 0 16.10.2011 03:21
Поиск изображения в RichEdit artemavd Общие вопросы Delphi 6 23.04.2011 09:45