Próbuję od kilku dni napisać prostą kolorowankę w Delphi 7.
Znalazłam trochę, ale nie daję rady z wypełnieniem.
unit koloro;
interface
{$R RESOURCE.RES RESOURCE.RC}
uses
Jpeg, Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtDlgs, StdCtrls, ExtCtrls, ColorGrd, Grids, ComCtrls,
Menus, Clipbrd, Buttons, ToolWin;
type
TForm1 = class(TForm)
Button4: TButton; //zamyka
Button8: TButton; //kaczor
Button9: TButton; //kubuspro
Button10: TButton;//kubus
Button11: TButton; //pluto
Button13: TButton; //tomjerry
Button2: TButton; //zapisz
Button3: TButton; //drukuj
Button14: TButton; //ust druku
Button7: TButton; //kolor
SavePictureDialog1: TSavePictureDialog;
PrinterSetupDialog1: TPrinterSetupDialog;
ColorDialog1: TColorDialog;
PrintDialog1: TPrintDialog;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
procedure Button4Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button8Click(Sender: TObject);
procedure Button10Click(Sender: TObject);
procedure Button9Click(Sender: TObject);
procedure Button11Click(Sender: TObject);
procedure Button13Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button14Click(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
end;
var
Form1: TForm1;
bm: TBitmap;
CurrentColor: TColor = clBlack;
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;
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 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,w: 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;
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 TForm1.FormCreate(Sender: TObject);
begin
bm := TBitmap.Create;
end;
procedure GDIBitmapAssign(Bitmap: TBitmap; const Pixmap: TASPixmap);
var
y: Integer;
scanline: PScanline;
bytewidth: integer;
begin
Bitmap.PixelFormat := pf32bit;
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 TForm1.FormPaint(Sender: TObject);
var
bmp:TBitmap;
begin
Canvas.Draw(0, bmp.Height, bm);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
close;
end;
}
procedure TForm1.Button3Click(Sender: TObject); //drukuj
begin
PrintDialog1.Execute;
end;
procedure TForm1.Button8Click(Sender: TObject);
var
Bitmap : TBitmap;
begin
with form1 do with canvas do
begin
brush.Color := color;
fillrect(rect(0,0,width,height));
end;
Bitmap := TBitmap.Create;
Bitmap.LoadFromResourceName(hInstance, 'kaczor');
Canvas.Draw(0, 0, Bitmap);
Bitmap.Free;
end;
procedure TForm1.Button10Click(Sender: TObject);
var
Bitmap : TBitmap;
begin
with form1 do with canvas do
begin
brush.Color := color;
fillrect(rect(0,0,width,height));
end;
Bitmap := TBitmap.Create;
Bitmap.LoadFromResourceName(hInstance, 'kubus');
Canvas.Draw(0, 0, Bitmap);
Bitmap.Free;
end;
procedure TForm1.Button9Click(Sender: TObject);
var
Bitmap : TBitmap;
begin
with form1 do with canvas do
begin
brush.Color := color;
fillrect(rect(0,0,width,height));
end;
Bitmap := TBitmap.Create;
Bitmap.LoadFromResourceName(hInstance, 'kubuspro');
Canvas.Draw(0, 0, Bitmap);
Bitmap.Free;
end;
procedure TForm1.Button11Click(Sender: TObject);
var
Bitmap : TBitmap;
begin
with form1 do with canvas do
begin
brush.Color := color;
fillrect(rect(0,0,width,height));
end;
Bitmap := TBitmap.Create;
Bitmap.LoadFromResourceName(hInstance, 'pluto');
Canvas.Draw(0, 0, Bitmap);
Bitmap.Free;
end;
procedure TForm1.Button13Click(Sender: TObject);
var
Bitmap : TBitmap;
begin
with form1 do with canvas do
begin
brush.Color := color;
fillrect(rect(0,0,width,height));
end;
Bitmap := TBitmap.Create;
Bitmap.LoadFromResourceName(hInstance, 'tj');
Canvas.Draw(0, 0, Bitmap);
Bitmap.Free;
end;
procedure TForm1.Button7Click(Sender: TObject);
begin
with TColorDialog.Create(self) do
try
Color := CurrentColor;
Options := [cdFullOpen];
if Execute then
CurrentColor := Color;
finally
Free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SavePictureDialog1.Execute;
end;
procedure TForm1.Button14Click(Sender: TObject);
begin
PrinterSetupDialog1.Execute;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
x0, y0: integer;
pm: TASPixmap;
begin
x0 := X;
y0 := Y - GroupBox1.Height;
if IsIntInInterval(x0, 0, GroupBox1.Width) and IsIntInInterval(y0, 0, GroupBox1.Height) then
begin
pm := GDIBitmapToASPixmap(bm);
pm := PMFloodFill(pm, x0, y0, CurrentColor);
GDIBitmapAssign(bm, pm);
end;
end;
end.
To co jest w komentarzu ( {} ) tego nie pojmuję i na 99,9% tam jest błąd.
Obrazki wczytuję z resource'a, działa.
Po uruchomieniu pokazuje się wybór obrazków, po wciśnięci odpowiedniego przycisku pokazuje się dany obrazek, ale po wybraniu koloru dany obszar nie wypełnia się.
Tu pytanie:
- Czy da się prościej napisać wypełnienie danych kształtów?
- Dlaczego po wybraniu koloru i kliknięciu na obrazek nie wypełnia się?
PS: Bitmapę wczytuję na formularzu, bo w image1 i paintbox1 wywalało mi ciągle błędy.
Delphi 
