Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Media";
Текущий архив: 2004.08.01;
Скачать: [xml.tar.bz2];

Вниз

Заливка произвольной области   Найти похожие ветки 

 
X-Disa ©   (2004-05-12 14:03) [0]

Я делаю заливку произвольной области на Bitmap по такому (рекурсивному)алгоритму:


Procedure FillPlace(Bitmap:TBitmap;X,Y:integer;Color:TColor);
Var OldColor:TCOlor;
Begin
 OldColor:=Bitmap.Canvas.Pixels[X,Y];
 if OldColor<>Color then fillcol(Bitmap,X,Y,Color,OldCOlor);
End;

Procedure FillRow(Bitmap:TBitmap;X,Y:integer;Color,OldColor:TColor);
Begin
 if (Bitmap.Canvas.Pixels[X,Y]=OldColor)and(x<=Bitmap.Width)and(x>=0) then begin
    Bitmap.Canvas.Pixels[X,Y]:=color;
    fillcol(Bitmap,x-1,y,Color,OldCOlor);
    fillcol(Bitmap,x+1,y,Color,OldCOlor);
 end;
End;

Procedure FillCol(Bitmap:TBitmap;X,Y:integer;Color,OldColor:TColor);
Begin
 if (Bitmap.Canvas.Pixels[X,Y]=OldCOlor)and(y>=0)and(y<=Bitmap.Height) then begin
    Bitmap.Canvas.canvas.Pixels[X,Y]:=color;
    fillrow(Bitmap,x,y+1,Color,OldCOlor);
    fillrow(Bitmap,x,y-1,Color,OldCOlor);
 End;
End;

Для заливки в процедуре FillPlace указываются координаты X Y и цвет, которым заливать. Проблема в том, что при заливке больших областей происходит переполнение стека. Может есть какой нибудь другой алгоритм?


 
Думкин ©   (2004-05-12 14:07) [1]

Есть.
Canvas.FloodFill()


 
X-Disa ©   (2004-05-12 14:16) [2]

Нет, это не совсем то. Flood Fill заливает всю область, даже если она не одноцветная. А мне нужно: Если есть например область белого цвета с произвольной границей (не обязательно одноцветной), должна закраситься только белая область.


 
Mihey ©   (2004-05-12 17:35) [3]

FloodFill(X, Y, clWhite, fsSurface);


 
X-Disa ©   (2004-05-13 14:48) [4]

Я поставил это на OnMouseDown в TImage, цвет заливки clRed, но что то не работает. Проверил на разных фигурах (Одноцветная заливка)


 
Mihey ©   (2004-05-13 15:13) [5]

То же самое сделал - работает:


unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
 TmainForm = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure FormPaint(Sender: TObject);
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 mainForm: TmainForm;
 Bmp: TBitmap;

implementation

{$R *.DFM}

procedure TmainForm.FormCreate(Sender: TObject);
begin
 Bmp := TBitmap.Create;
 Bmp.Width := 300;
 Bmp.Height := 200;
 With Bmp.Canvas do
  begin
   Pen.Color := clBlack;
   Brush.Color := clBlue;
   FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
   Pen.Color := clWhite;
   Brush.Color := clWhite;
   Ellipse(Rect(0+30, 0+30, Bmp.Width-30, Bmp.Height-30));
  end;
end;

procedure TmainForm.FormDestroy(Sender: TObject);
begin
 Bmp.Free;
end;

procedure TmainForm.FormPaint(Sender: TObject);
begin
 BitBlt(Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SrcCopy);
end;

procedure TmainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 If (X < Bmp.Width) and (Y < Bmp.Height) then
  begin
   Bmp.Canvas.Brush.Color := clYellow;
   Bmp.Canvas.FloodFill(X, Y, clWhite, fsSurface);
  end;
 Invalidate;
end;

end.


 
Mihey ©   (2004-05-13 15:15) [6]

Наверное, ты путаешь что-то с параметрами. В FloodFill нужно указывать цвет поверхности, которая будет залита цветом, установленным в Brush.Color.


 
X-Disa ©   (2004-05-13 15:36) [7]

Спасибо, теперь работает!



Страницы: 1 вся ветка

Форум: "Media";
Текущий архив: 2004.08.01;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.47 MB
Время: 0.049 c
3-1089273635
AlexanderSK
2004-07-08 12:00
2004.08.01
Как узнать ключевые поля таблицы?


1-1089898891
DSKalugin
2004-07-15 17:41
2004.08.01
закраска в StringGrid


3-1089189160
reticon
2004-07-07 12:32
2004.08.01
Подключение к PostgreSQL


3-1089347346
ALexey
2004-07-09 08:29
2004.08.01
IBX и вычисляемые поля в Firebird 1.5 под Linux


14-1089968001
DimKa
2004-07-16 12:53
2004.08.01
За что Вам нравится данных сайт?





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский