Is it possible to use "Fill with color" function on Delphi's Image component?

I have a TImage component on the form. I need to impleme开发者_开发技巧nt the following functionality:

(If mouse pointer is over point with red color, then apply "Fill with color green" to that point)

Here by "Fill with color" I mean Paint's function "Fill with color". Is there anything similar in TImage? Or should I implement this function myself?

Thank you

P.S. I use Delphi 7

I guess you are talking about "flood fill". Some time ago, I wrote my own implementation of this based on the Wikipedia article. I represent the bitmap as a two-dimensional array of TRGBQuad pixels.

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;

The complete code is

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.

Project files

For your convenience, you can download the entire project from

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

Don't forget the sample bitmap.

There's nothing built in to TImage to do what you ask.

You could implement yourself although you would probably not start from TImage. Or perhaps you might have some fortune searching for a 3rd party painting component that offered the functionality you need.

Actually I managed to implement this using Image1.Canvas.FloodFill function. I just had to scale the coordinates using (Image1.ClientWidth/Image1.Picture.Bitmap.Width) ratio (same for height). After getting new coordinates I could get the color of point by using Image1.Canvas.Pixels matrix and scaled coordinates. Seems to work fine with me, and no need for additional functions.