是否可以在Delphi Image组件中使用“填充颜色”功能？

Question

我在表单上有一个TImage组件。我需要实现以下功能：

（如果鼠标指针在红点上方，请将“填充颜色为绿色”应用于该点）

这里的“填充颜色”是指Paint的功能“填充颜色”。 TImage中有类似的东西吗？或者我应该自己实现这个功能吗？

谢谢

P.S。我使用的是Delphi 7

Answer 1

我猜你说的是“洪水填充”。前段时间，我根据Wikipedia article编写了自己的实现。我将位图表示为TRGBQuad像素的二维数组。

function PMFloodFill(Pixmap: TASPixmap; const X0: integer; const Y0: integer; const Color: TColor): TASPixmap;
var
  w, h: integer;
  MatchColor, QColor: TRGBQuad;
  Queue: packed {SIC!} array of TPoint;
  cp: TPoint;

  procedure push(Point: TPoint);
  begin
    SetLength(Queue, length(Queue) + 1);
    Queue[High(Queue)] := Point;
  end;

  function pop: TPoint;
  var
    lm1: integer;
  begin
    assert(length(Queue) > 0);
    result := Queue[0];
    lm1 := length(Queue) - 1;
    if lm1 > 0 then
      MoveMemory(@(Queue[0]), @(Queue[1]), lm1 * sizeof(TPoint));
    SetLength(Queue, lm1);
  end;

begin
  PMSize(Pixmap, h, w);
  result := Pixmap;
  if not (IsIntInInterval(X0, 0, w-1) and IsIntInInterval(Y0, 0, h-1)) then
    Exit;
  // Find color to match
  MatchColor := Pixmap[Y0, X0];
  QColor := PascalColorToRGBQuad(Color);
  SetLength(Queue, 0);
  push(point(X0, Y0));
  while length(Queue) > 0 do
  begin
    if RGBQuadEqual(result[Queue[0].Y, Queue[0].X], MatchColor) then
      result[Queue[0].Y, Queue[0].X] := QColor;

    cp := pop;

    if cp.X > 0 then
      if RGBQuadEqual(result[cp.Y, cp.X - 1], MatchColor) then
      begin
        result[cp.Y, cp.X - 1] := QColor;
        push(point(cp.X - 1, cp.Y));
      end;

    if cp.X < w-1 then
      if RGBQuadEqual(result[cp.Y, cp.X + 1], MatchColor) then
      begin
        result[cp.Y, cp.X + 1] := QColor;
        push(point(cp.X + 1, cp.Y));
      end;

    if cp.Y > 0 then
      if RGBQuadEqual(result[cp.Y - 1, cp.X], MatchColor) then
      begin
        result[cp.Y - 1, cp.X] := QColor;
        push(point(cp.X, cp.Y - 1));
      end;

    if cp.Y < h-1 then
      if RGBQuadEqual(result[cp.Y + 1, cp.X], MatchColor) then
      begin
        result[cp.Y + 1, cp.X] := QColor;
        push(point(cp.X, cp.Y + 1));
      end;
  end;
end;

完整的代码是

unit Unit4;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ToolWin;

type
  TForm4 = class(TForm)
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    procedure ToolButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ToolButton2Click(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    procedure UpdateBitmap(Sender: TObject);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form4: TForm4;
  bm: TBitmap;
  CurrentColor: TColor = clRed;

implementation

{$R *.dfm}

type
  TASPixmap = array of packed array of TRGBQuad;

  TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;
  PRGB32Array = ^TRGB32Array;

  TScanline = TRGB32Array;
  PScanline = ^TScanline;

function IsIntInInterval(x, xmin, xmax: integer): boolean; {inline;}
begin
  IsIntInInterval := (xmin <= x) and (x <= xmax);
end;

function PascalColorToRGBQuad(const Color: TColor): TRGBQuad;
begin
  with Result do
  begin
    rgbBlue := GetBValue(Color);
    rgbGreen := GetGValue(Color);
    rgbRed := GetRValue(Color);
    rgbReserved := 0;
  end;
end;

function RGBQuadEqual(const Color1: TRGBQuad; const Color2: TRGBQuad): boolean;
begin
  RGBQuadEqual := (Color1.rgbBlue = Color2.rgbBlue) and
                  (Color1.rgbGreen = Color2.rgbGreen) and
                  (Color1.rgbRed = Color2.rgbRed);
end;

function PMFloodFill(Pixmap: TASPixmap; const X0: integer; const Y0: integer; const Color: TColor): TASPixmap;
var
  w, h: integer;
  MatchColor, QColor: TRGBQuad;
  Queue: packed {SIC!} array of TPoint;
  cp: TPoint;

  procedure push(Point: TPoint);
  begin
    SetLength(Queue, length(Queue) + 1);
    Queue[High(Queue)] := Point;
  end;

  function pop: TPoint;
  var
    lm1: integer;
  begin
    assert(length(Queue) > 0);
    result := Queue[0];
    lm1 := length(Queue) - 1;
    if lm1 > 0 then
      MoveMemory(@(Queue[0]), @(Queue[1]), lm1 * sizeof(TPoint));
    SetLength(Queue, lm1);
  end;

begin
  h := length(Pixmap);
  if h > 0 then
    w := length(Pixmap[0]);
  result := Pixmap;
  if not (IsIntInInterval(X0, 0, w-1) and IsIntInInterval(Y0, 0, h-1)) then
    Exit;
  // Find color to match
  MatchColor := Pixmap[Y0, X0];
  QColor := PascalColorToRGBQuad(Color);
  SetLength(Queue, 0);
  push(point(X0, Y0));
  while length(Queue) > 0 do
  begin
    if RGBQuadEqual(result[Queue[0].Y, Queue[0].X], MatchColor) then
      result[Queue[0].Y, Queue[0].X] := QColor;

    cp := pop;

    if cp.X > 0 then
      if RGBQuadEqual(result[cp.Y, cp.X - 1], MatchColor) then
      begin
        result[cp.Y, cp.X - 1] := QColor;
        push(point(cp.X - 1, cp.Y));
      end;

    if cp.X < w-1 then
      if RGBQuadEqual(result[cp.Y, cp.X + 1], MatchColor) then
      begin
        result[cp.Y, cp.X + 1] := QColor;
        push(point(cp.X + 1, cp.Y));
      end;

    if cp.Y > 0 then
      if RGBQuadEqual(result[cp.Y - 1, cp.X], MatchColor) then
      begin
        result[cp.Y - 1, cp.X] := QColor;
        push(point(cp.X, cp.Y - 1));
      end;

    if cp.Y < h-1 then
      if RGBQuadEqual(result[cp.Y + 1, cp.X], MatchColor) then
      begin
        result[cp.Y + 1, cp.X] := QColor;
        push(point(cp.X, cp.Y + 1));
      end;
  end;
end;

function GDIBitmapToASPixmap(const Bitmap: TBitmap): TASPixmap;
var
  scanline: PScanline;
  width, height, bytewidth: integer;
  y: Integer;
begin

  Bitmap.PixelFormat := pf32bit;

  width := Bitmap.Width;
  height := Bitmap.Height;
  bytewidth := width * 4;

  SetLength(Result, height);
  for y := 0 to height - 1 do
  begin
    SetLength(Result[y], width);
    scanline := @(Result[y][0]);
    CopyMemory(scanline, Bitmap.ScanLine[y], bytewidth);
  end;

end;

procedure GDIBitmapAssign(Bitmap: TBitmap; const Pixmap: TASPixmap);
var
  y: Integer;
  scanline: PScanline;
  bytewidth: integer;
begin
  Bitmap.PixelFormat := pf32bit;
  Bitmap.SetSize(length(Pixmap[0]), length(Pixmap));
  bytewidth := Bitmap.Width * 4;

  for y := 0 to Bitmap.Height - 1 do
  begin
    scanline := @(Pixmap[y][0]);
    CopyMemory(Bitmap.ScanLine[y], scanline, bytewidth);
  end;
end;

procedure TForm4.FormCreate(Sender: TObject);
begin
  bm := TBitmap.Create;
end;

procedure TForm4.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  x0, y0: integer;
  pm: TASPixmap;
begin
  x0 := X;
  y0 := Y - ToolBar1.Height;

  if IsIntInInterval(x0, 0, bm.Width) and IsIntInInterval(y0, 0, bm.Height) then
  begin
    pm := GDIBitmapToASPixmap(bm);
    pm := PMFloodFill(pm, x0, y0, CurrentColor);
    GDIBitmapAssign(bm, pm);
    UpdateBitmap(Self);
  end;
end;

procedure TForm4.FormPaint(Sender: TObject);
begin
  Canvas.Draw(0, ToolBar1.Height, bm);
end;

procedure TForm4.UpdateBitmap(Sender: TObject);
begin
  Invalidate;
end;

procedure TForm4.ToolButton1Click(Sender: TObject);
begin
  with TOpenDialog.Create(self) do
    try
      Filter := 'Windows Bitmaps (*.bmp)|*.bmp';
      Title := 'Open Bitmap';
      Options := [ofPathMustExist, ofFileMustExist];
      if Execute then
      begin
        bm.LoadFromFile(FileName);
        UpdateBitmap(Sender);
      end;
    finally
      Free;
    end;
end;

procedure TForm4.ToolButton2Click(Sender: TObject);
begin
  with TColorDialog.Create(self) do
    try
      Color := CurrentColor;
      Options := [cdFullOpen];
      if Execute then
        CurrentColor := Color;
    finally
      Free;
    end;
end;

end.

Flood Fill Sample Application http://privat.rejbrand.se/floodfill.png

项目文件

为方便起见，您可以从

下载整个项目

• http://privat.rejbrand.se/floodfill.zip

不要忘记sample bitmap。

Answer 2

TImage没有内置任何内容可以执行您的要求。

你可以自己实现，尽管你可能不会从TImage开始。或者也许你可能会有一些财富来寻找提供所需功能的第三方绘画组件。

Answer 3

实际上我设法使用Image1.Canvas.FloodFill函数来实现它。我只需要使用（Image1.ClientWidth / Image1.Picture.Bitmap.Width）比例（高度相同）来缩放坐标。获得新坐标后，我可以使用Image1.Canvas.Pixels矩阵和缩放坐标获得点的颜色。好像和我一起工作，不需要额外的功能。