I have a TImage component on the form. I need to implement 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
PS 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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.