В первом приближении получилось нечто изрядно корявое ..
(Пока обедал понял что у меня "логическая яма" образовалась и нет обработки нескольких ситуаций с пространственным расположением нескольких контуров )
Но тем не менее идея "проста как двери" !
Обходим найденный пиксель по квадрату и увеличиваем квадрат пока в нем есть точки ...
Но может кто-то видел готовую функцию ?
Зы
Текущая недоделка ...
- Код: Выделить всё
Function MyScanOBJ(Var image:tBitmap;x,y:Longint):trect;
Var
W,H:Longint;
I,J:Longint;
XN,YN,XK,YK:Longint;
FE:Boolean ;
begin
W:=image.Width;
H:=image.Height;
Result.Left:=X;
Result.Right:=X;
Result.Top:=Y;
Result.Bottom:=Y;
XN:=X;YN:=Y;
XK:=X;YK:=Y;
Set_Pixel(Image,X,Y, clRed);
Repeat
XN:=XN-1;
YN:=YN-1;
XK:=XK+1;
YK:=YK+1;
FE:=False;
For I:=XN to XK Do
if (i in [0..W-1]) then
begin
if (YN in [0..H-1]) then
if (get_Pixel(Image,I,YN)= clBlack) then
begin
Set_Pixel(Image,I,YN, clRed);
FE:=True;
Result.Top:=YN;
End;
if (YK in [0..H-1]) then
if (Get_Pixel(Image,I,YK)= clBlack) then
begin
Set_Pixel(Image,I,YK, clRed);
FE:=True;
Result.Bottom:=YK;
End;
end;
For J:=YN to YK Do
if I in [0..H-1] then
begin
if XN in [0..W-1] then
if (Get_Pixel(Image,XN,J)= clBlack) then
begin
Set_Pixel(Image,Xn,J, clRed);
FE:=True;
Result.Left:=XN;
End;
if (XK in [0..W-1]) then
if (Get_Pixel(Image,XK,J)= clBlack) then
begin
Set_Pixel(Image,XK,J, clRed);
FE:=True;
Result.Right:=XK;
End
end;
until Not Fe;
end;
// Массовый поиск и запоминание границ
procedure MyScanOBJECTS(Var RL:TList; Var image:tBitmap;x,y,DR:Longint);
Var
W,H:Longint;
R:^Trect;
Lf:Boolean;
begin
If image=nil then exit; // !! Тут была наглая опечатка ... :))
Lf:=False;
Repeat
Lf:=False;
W:=image.Width-1;
H:=image.Height-1;
For Y:=0 to W do
For X:=0 to H do
begin
if Get_Pixel(image,x,y)=clBlack then begin
GetMem(R,SizeOf(Trect));
R^:=MyScanOBJ(image,x,y );
// Проверка длинны "косой сажени" то бишь диагонали
if Sqrt(Sqr(ABS(r.Bottom-R.Top))+Sqr(ABS(R.Right-r.Left)))>DR then
begin
RL.Add(R) ;
LF:=True;
end else FreeMem(R,SizeOf(Trect));
end
end;
Until not LF;
end;