задача у меня сделать относительно быстрый поиск фрагмента изображениия . решил начать с поиска фрагмента сделал. понял что работает медленно для ускарения решил разбить картинку поиска на несколько частей и пройтись поним в подзадачах и тут начались проблемы:
Имеется программа которая должно искать на большой картинке фрагмет. Вот код :
Код:
procedure TForm1.Button1Click(Sender: TObject);
var
x: Integer;
y: Integer;
x1: Integer;
y1:Integer;
flag: Boolean;
begin
Form1.Caption :='';
for x := 1 to 100 Image2.Picture.Width do
begin
for y := 1 to 100 Image2.Picture.Height do
begin
flag := True;
for x1 := 1 to Image1.Picture.Width-1 do
begin
for y1 := 1 to Image1.Picture.Height-1 do
begin
if Image2.Picture.Bitmap.Canvas.Pixels[x1+x,y1+y] <> Image1.Picture.Bitmap.Canvas.Pixels[x1,y1] then
begin
flag := False;
Break;
end;
end;
end;
if flag = True then
begin
Form1.Caption := 'Нащел х='+x.ToString+' y='+y.ToString;
Exit;
end;
Form1.Caption := 'не нащел х='+x.ToString+' y='+y.ToString;
Application.ProcessMessages;
end;
end;
end;
Естественно это будет работать очень долго для ускорения процеса появилась идея разрезать исходную картинку на несколько частей и обрабатывать их в подзадачаз возвращая результат.
Родился ваоттакой код :
Код:
unit Unit2;
interface
uses
System.Classes, System.SysUtils, Vcl.Graphics;
type
ClaasXZ = class(TThread)
private
procedure UpPoint();
protected
procedure Execute; override;
public
end;
implementation
uses
Unit1;
{ ClaasXZ }
VAR
Tx: Integer;
Ty: Integer;
Tx1: Integer;
Ty1: Integer;
Tflag: Boolean;
tBworc :TBitmap;
ttemplate: TBitmap;
procedure ClaasXZ.UpPoint();
begin
Form1.Caption := 'Нащел х=' + Tx.ToString + ' y=' + Ty.ToString;
end;
procedure ClaasXZ.Execute;
begin
tBworc:=TBitmap.Create; //Создаем битмапы и присваиваем им размеры
tBworc.Width:= 100;
tBworc.Height := 100;
ttemplate:=TBitmap.Create;
ttemplate.Width := 41 ;
ttemplate.Height := 23;
tBworc.LoadFromFile('1.BMP'); //Картинка на которой ищем
ttemplate.LoadFromFile('1.bmp');//Картинка которую ищем
for tx := 1 to tBworc.Width do
begin
for ty := 1 to tBworc.Height do
begin
tflag := True;
for tx1 := 1 to ttemplate.Width - 1 do
begin
for ty1 := 1 to ttemplate.Height - 1 do
begin
if tBworc.Canvas.Pixels[Tx1 + Tx, Ty1 + Ty] <> ttemplate.Canvas.Pixels[Tx1, Ty1] then
begin
tflag := False;
Break;
end;
end;
end;
if tflag = True then
begin
Synchronize(UpPoint);
Terminate;
Exit;
end;
end;
end;
end;
end.
Админ: Пользуемся тегами при оформлении кода!
посути это одно и тоже как я понимаю только в подзадаче работает через раз то срабатывает выводя верные координаты то не работает а именно примерно раз из 5 находит совпадения остальные 4 раза выдает неверные координаты (( !!! подскажите почему.