Можно ли использовать функцию «Заполнить цветом» в компоненте Image Delphi? - PullRequest
Новая
       17

Можно ли использовать функцию «Заполнить цветом» в компоненте Image Delphi?

1 голос
/ 15 февраля 2011

У меня есть компонент TImage в форме.Мне нужно реализовать следующие функциональные возможности:

(если указатель мыши находится над точкой красным цветом, тогда примените к этой точке «заливку зеленым цветом»)

Здесь с помощью «заливки цветом»Я имею в виду функцию Paint "Заполнить цветом".Есть ли что-нибудь подобное в TImage?Или я должен сам реализовать эту функцию?

Спасибо

PS Я использую Delphi 7

Ответы [ 3 ]

5 голосов
/ 15 февраля 2011

Полагаю, вы говорите о "заливке". Некоторое время назад я написал собственную реализацию этого на основе статьи Википедии . Я представляю растровое изображение в виде двумерного массива 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.

Образец заявки на заливку http://privat.rejbrand.se/floodfill.png

Файлы проекта

Для вашего удобства вы можете скачать весь проект с

Не забудьте образец растрового изображения .

0 голосов
/ 17 февраля 2011

На самом деле мне удалось реализовать это с помощью функции Image1.Canvas.FloodFill.Мне просто нужно было масштабировать координаты, используя соотношение (Image1.ClientWidth / Image1.Picture.Bitmap.Width) (то же самое для высоты).После получения новых координат я мог получить цвет точки, используя матрицу Image1.Canvas.Pixels и масштабированные координаты.Кажется, хорошо работает со мной, и нет необходимости в дополнительных функциях.

0 голосов
/ 15 февраля 2011

Нет ничего встроенного в TImage для выполнения того, что вы просите.

Вы можете реализовать себя, хотя, вероятно, не начнете с TImage.Или, может быть, вам повезло в поиске стороннего компонента рисования, который предлагал вам необходимую функциональность.

...