粒子计数(200分)

如何对图像中随机分布的不同大小颗粒，进行标记、计数和分类。急需解答，还可重酬！

假设图像中的颗粒具有相同颜色，且与底片不同的颜色。

首先对图像中进行搜索（如从左到右，从上到下），对搜索到的第一个颗粒颜色的点，进行水平和
垂直扩展，于是得到了第一个颗粒。对图像继续进行搜索，重复上面步骤。

不知我理解得对不对，呵呵。

让我先试一试。

你和我现在做的照片分割目的差不多。先二值化，粒子颜色用1表示。背景用0表示。
再分割。

type
TCell = record
Left, Top, Right, Bottom: Integer;
Size: Integer;
end;

function GetCell(Bmp: TBitmap; x, y: Integer): TCell;
const
dx: array [1..4] of Integer = (-1, 0, 1, 0);
dy: array [1..4] of Integer = ( 0,-1, 0, 1);
var
Ptr: PByteArray;
Cell: TCell;
i, nx, ny: Integer;
begin
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
with Result do begin
Left := x;
Right := x;
Top := y;
Bottom := y;
Size := 1;
end;
for i := 1 to 4 do begin
nx := x + dx;
ny := y + dy;
if (nx >= 0) and (nx < Bmp.Width) and
(ny >= 0) and (ny < Bmp.Height) then begin
Ptr := Bmp.ScanLine[ny];
if Ptr[nx] <> 0 then begin
Cell := GetCell(Bmp, nx, ny);
with Result do begin
if Cell.Left < Left then Left := Cell.Left;
if Cell.Right > Right then Right := Cell.Right;
if Cell.Top < Top then Top := Cell.Top;
if Cell.Bottom > Bottom then Bottom := Cell.Bottom;
Inc(Size, Cell.Size);
end;
end;
end;
end;
end;

function CellToString(Cell: TCell): String;
begin
Result := Format('(%d, %d) - (%d, %d): %d',
[Cell.Left, Cell.Top, Cell.Right, Cell.Bottom, Cell.Size]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Bmp: TBitmap;
Ptr: PByteArray;
i, j: Integer;
Cell: TCell;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile('d:/myfiles/Cells.bmp');
Bmp.PixelFormat := pf8Bit;
for i := 0 to Bmp.Height - 1 do begin
Ptr := Bmp.ScanLine;
for j := 0 to Bmp.Width - 1 do
if Ptr[j] <> 0 then begin
Cell := GetCell(Bmp, j, i);
ListBox1.Items.Add(CellToString(Cell));
end;
end;
finally
Bmp.Free;
end;
end;

程序假设图片是单色，即颗粒是白色，背景是黑色。

结果返回颗粒的大小，以及包含颗粒的最小矩形框。

johnsonguo兄:
多谢，我试用了你的代码，我用了TOpenPictureDialog和TImage，
用于打开不同二值化图像，显示二值化图像后再计数分析，第一次打开
的二值化图像可以分析，但不知为何，分析完后，再打开图像时程序
出错，如不进行计数分析，则可以再打开其他图像，不会出错。请不吝赐教。
另外，找到某点扩展时，是否应考虑8个方向，而不仅仅是4个方向。
同时我想将每个粒子的边缘标记出来，该如何进行。我会再送分。
附我的程序如下：
type
TCell = record
Left, Top, Right, Bottom: Integer;
Size: Integer;
end;

function GetCell(Bmp: TBitmap; x, y: Integer): TCell;
const
dx: array [1..4] of Integer = (-1, 0, 1, 0);
dy: array [1..4] of Integer = ( 0,-1, 0, 1);
var
Ptr: PByteArray;
Cell: TCell;
i, nx, ny: Integer;
begin
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
with Result do begin
Left := x;
Right := x;
Top := y;
Bottom := y;
Size := 1;
end;
for i := 1 to 4 do begin
nx := x + dx;
ny := y + dy;
if (nx >= 0) and (nx < Bmp.Width) and
(ny >= 0) and (ny < Bmp.Height) then begin
Ptr := Bmp.ScanLine[ny];
if Ptr[nx] <> 0 then begin
Cell := GetCell(Bmp, nx, ny);
with Result do begin
if Cell.Left < Left then Left := Cell.Left;
if Cell.Right > Right then Right := Cell.Right;
if Cell.Top < Top then Top := Cell.Top;
if Cell.Bottom > Bottom then Bottom := Cell.Bottom;
Inc(Size, Cell.Size);
end;
end;
end;
end;
end;

function CellToString(Cell: TCell): String;
begin
Result := Format('(%d, %d) - (%d, %d): %d',
[Cell.Left, Cell.Top, Cell.Right, Cell.Bottom, Cell.Size]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Bmp: TBitmap;
Ptr: PByteArray;
i, j: Integer;
Cell: TCell;
begin
Bmp := TBitmap.Create;
try
Bmp:=image1.Picture.Bitmap;
Bmp.PixelFormat := pf8Bit;
for i := 0 to Bmp.Height - 1 do begin
Ptr := Bmp.ScanLine;
for j := 0 to Bmp.Width - 1 do
if Ptr[j] <> 0 then begin
Cell := GetCell(Bmp, j, i);
ListBox1.Items.Add(CellToString(Cell));
end;
end;
finally
Bmp.Free;
end;
end;

procedure TForm1.bbtnOpenClick(Sender: TObject);
begin
try
if openpicturedialog1.Execute then
image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
finally
end;
end;

我的疑问:
为什么不向周围的8个方向搜索?

johnsonguo兄:
我将的程序中的Bmp:=image1.Picture.Bitmap;
改为Bmp.assign(image1.Picture.Bitmap)后就可以了，让你见笑;
还请回答：
找到某点扩展时，是否应考虑8个方向，而不仅仅是4个方向，具体怎么改。
同时我想将每个粒子的边缘标记出来，该如何进行。

Reboot兄：
能否具体点。

真不好意思，这里的网络很慢，所以现在才能答。

改为8个方向，只须修改dx,dy数组，以及改一下就可以了，程序如下：

type
TCell = record
Left, Top, Right, Bottom: Integer;
Size: Integer;
end;

function GetCell(Bmp: TBitmap; x, y: Integer): TCell;
const
dx: array [1..8] of Integer = (-1, 0, 1, 0,-1,-1, 1, 1);
dy: array [1..8] of Integer = ( 0,-1, 0, 1, 1,-1, 1,-1);
var
Ptr: PByteArray;
Cell: TCell;
i, nx, ny: Integer;
begin
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
with Result do begin
Left := x;
Right := x;
Top := y;
Bottom := y;
Size := 1;
end;
for i := 1 to 8 do begin
nx := x + dx;
ny := y + dy;
if (nx >= 0) and (nx < Bmp.Width) and
(ny >= 0) and (ny < Bmp.Height) then begin
Ptr := Bmp.ScanLine[ny];
if Ptr[nx] <> 0 then begin
Cell := GetCell(Bmp, nx, ny);
with Result do begin
if Cell.Left < Left then Left := Cell.Left;
if Cell.Right > Right then Right := Cell.Right;
if Cell.Top < Top then Top := Cell.Top;
if Cell.Bottom > Bottom then Bottom := Cell.Bottom;
Inc(Size, Cell.Size);
end;
end;
end;
end;
end;

function CellToString(Cell: TCell): String;
begin
Result := Format('(%d, %d) - (%d, %d): %d',
[Cell.Left, Cell.Top, Cell.Right, Cell.Bottom, Cell.Size]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Bmp: TBitmap;
Ptr: PByteArray;
i, j: Integer;
Cell: TCell;
begin
if OpenPictureDialog1.Execute then begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile(OpenPictureDialog1.FileName);
if Bmp.PixelFormat <> pf1Bit then begin
ShowMessage('此位图不是单色位图！');
Exit;
end;
Bmp.PixelFormat := pf8Bit;
for i := 0 to Bmp.Height - 1 do begin
Ptr := Bmp.ScanLine;
for j := 0 to Bmp.Width - 1 do
if Ptr[j] <> 0 then begin
Cell := GetCell(Bmp, j, i);
ListBox1.Items.Add(CellToString(Cell));
end;
end;
finally
Bmp.Free;
end;
end;
end;

我不知道你提的第二个问题的意思，我是这样处理的：
首先对图片进行边缘检测，然后再对经过边缘检测的图片进行上面的操作，
并记录搜索过程中的点，便可以对边缘进行记录了。
边缘检测的一个简单方法程序如下：

procedure Calc(Bmp, Res: TBitmap; x, y: Integer);
var
Value: Integer;

function Pixels(x, y: Integer): Integer;
begin
if (x < 0) or (x >= Bmp.Width) or
(y < 0) or (y >= Bmp.Height) then
Result := 0
else
Result := Integer(PByteArray(Bmp.ScanLine[y])[x]);
end;

procedure SetPixels(Value: Byte);
begin
PByteArray(Res.ScanLine[y])[x] := Value;
end;

begin
Value := 8 * Pixels(x, y) - (
Pixels(x - 1, y - 1) + Pixels(x, y - 1)
+ Pixels(x + 1, y - 1) + Pixels(x - 1, y)
+ Pixels(x + 1, y) + Pixels(x - 1, y + 1)
+ Pixels(x, y + 1) + Pixels(x + 1, y + 1));
if Value < 10 then SetPixels(0)
else SetPixels(1);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Res, Bmp: TBitmap;
i, j: Integer;
begin
if OpenPictureDialog1.Execute then begin
Bmp := TBitmap.Create;
Res := TBitmap.Create;
try
Bmp.LoadFromFile(OpenPictureDialog1.FileName);
if Bmp.PixelFormat <> pf1Bit then begin
ShowMessage('此位图不是单色位图！');
Exit;
end;
Bmp.PixelFormat := pf8Bit;
Res.Width := Bmp.Width;
Res.Height := Bmp.Height;
Res.PixelFormat := pf8Bit;
for j := 0 to Bmp.Height - 1 do
for i := 0 to Bmp.Width - 1 do
Calc(Bmp, Res, i, j);
Res.PixelFormat := pf1Bit;
Res.SaveToFile('c:/a.bmp');
finally
Res.Free;
Bmp.Free;
end;
end;
end;

多谢 johnsonGuo兄！
小弟初学编程，能否解释function GetCell(Bmp: TBitmap; x, y: Integer）中
Cell := GetCell(Bmp, nx, ny);
该句的执行过程，我还不大明白。

哪是通过递归实现搜索颗粒。

johnsonGuo兄：
问题是程序是如何避免了重复计数，扫描是逐点进行的呀，
程序是如何跳过已经参与过计数的像素点，请解释。

begin
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
~~~~~~~~~~~ 就是这一句，把已计数的点改为黑色，从而避免重复计数。
with Result do begin