My application needs a lot of PNGs and I often mess up my code while trying to work with them. To make my life easier I made one big PNG image in Realword Paint and pasted all those small PNG images on to it. Now I have one file instead. Now all I need is to copy one PNG on to other with transparency (btw don't ask why), because I need to work with each image induvidually. I am bad programmer when it comes to working with images. I am using Delphi 7.
PGNImage.Resize
procedure TPngObject.Resize(const CX, CY: Integer);
function Min(const A, B: Integer): Integer;
begin
if A < B then Result := A else Result := B;
end;
var
Header: TChunkIHDR;
Line, NewBytesPerRow: Integer;
NewHandle: HBitmap;
NewDC: HDC;
NewImageData: Pointer;
NewImageAlpha: Pointer;
NewImageExtra: Pointer;
begin
if (CX > 0) and (CY > 0) then
begin
{Gets some actual information}
Header := Self.Header;
{Creates the new image}
NewDC := CreateCompatibleDC(Header.ImageDC);
Header.BitmapInfo.bmiHeader.biWidth := cx;
Header.BitmapInfo.bmiHeader.biHeight := cy;
NewHandle := CreateDIBSection(NewDC, pBitmapInfo(#Header.BitmapInfo)^,
DIB_RGB_COLORS, NewImageData, 0, 0);
SelectObject(NewDC, NewHandle);
{$IFDEF UseDelphi}Canvas.Handle := NewDC;{$ENDIF}
NewBytesPerRow := (((Header.BitmapInfo.bmiHeader.biBitCount * cx) + 31)
and not 31) div 8;
{Copies the image data}
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageData) + (Longint(CY) - 1) *
NewBytesPerRow - (Line * NewBytesPerRow)), Scanline[Line],
Min(NewBytesPerRow, Header.BytesPerRow));
{Build array for alpha information, if necessary}
if (Header.ColorType = COLOR_RGBALPHA) or
(Header.ColorType = COLOR_GRAYSCALEALPHA) then
begin
GetMem(NewImageAlpha, CX * CY);
Fillchar(NewImageAlpha^, CX * CY, 255);
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageAlpha) + (Line * CX)),
AlphaScanline[Line], Min(CX, Width));
FreeMem(Header.ImageAlpha);
Header.ImageAlpha := NewImageAlpha;
end;
{$IFDEF Store16bits}
if (Header.BitDepth = 16) then
begin
GetMem(NewImageExtra, CX * CY);
Fillchar(NewImageExtra^, CX * CY, 0);
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageExtra) + (Line * CX)),
ExtraScanline[Line], Min(CX, Width));
FreeMem(Header.ExtraImageData);
Header.ExtraImageData := NewImageExtra;
end;
{$ENDIF}
{Deletes the old image}
DeleteObject(Header.ImageHandle);
DeleteDC(Header.ImageDC);
{Prepares the header to get the new image}
Header.BytesPerRow := NewBytesPerRow;
Header.IHDRData.Width := CX;
Header.IHDRData.Height := CY;
Header.ImageData := NewImageData;
{Replaces with the new image}
Header.ImageHandle := NewHandle;
Header.ImageDC := NewDC;
end
else
{The new size provided is invalid}
RaiseError(EPNGInvalidNewSize, EInvalidNewSize)
end;
SmoothResize by Gustavo Daud
procedure SmoothResize(apng:tpngobject; NuWidth,NuHeight:integer);
var
xscale, yscale : Single;
sfrom_y, sfrom_x : Single;
ifrom_y, ifrom_x : Integer;
to_y, to_x : Integer;
weight_x, weight_y : array[0..1] of Single;
weight : Single;
new_red, new_green : Integer;
new_blue, new_alpha : Integer;
new_colortype : Integer;
total_red, total_green : Single;
total_blue, total_alpha: Single;
IsAlpha : Boolean;
ix, iy : Integer;
bTmp : TPNGObject;
sli, slo : pRGBLine;
ali, alo: pbytearray;
begin
if not (apng.Header.ColorType in [COLOR_RGBALPHA, COLOR_RGB]) then
raise Exception.Create('Only COLOR_RGBALPHA and COLOR_RGB formats' +
' are supported');
IsAlpha := apng.Header.ColorType in [COLOR_RGBALPHA];
if IsAlpha then new_colortype := COLOR_RGBALPHA else
new_colortype := COLOR_RGB;
bTmp := Tpngobject.CreateBlank(new_colortype, 8, NuWidth, NuHeight);
xscale := bTmp.Width / (apng.Width-1);
yscale := bTmp.Height / (apng.Height-1);
for to_y := 0 to bTmp.Height-1 do begin
sfrom_y := to_y / yscale;
ifrom_y := Trunc(sfrom_y);
weight_y[1] := sfrom_y - ifrom_y;
weight_y[0] := 1 - weight_y[1];
for to_x := 0 to bTmp.Width-1 do begin
sfrom_x := to_x / xscale;
ifrom_x := Trunc(sfrom_x);
weight_x[1] := sfrom_x - ifrom_x;
weight_x[0] := 1 - weight_x[1];
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
total_alpha := 0.0;
for ix := 0 to 1 do begin
for iy := 0 to 1 do begin
sli := apng.Scanline[ifrom_y + iy];
if IsAlpha then ali := apng.AlphaScanline[ifrom_y + iy];
new_red := sli[ifrom_x + ix].rgbtRed;
new_green := sli[ifrom_x + ix].rgbtGreen;
new_blue := sli[ifrom_x + ix].rgbtBlue;
if IsAlpha then new_alpha := ali[ifrom_x + ix];
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
if IsAlpha then total_alpha := total_alpha + new_alpha * weight;
end;
end;
slo := bTmp.ScanLine[to_y];
if IsAlpha then alo := bTmp.AlphaScanLine[to_y];
slo[to_x].rgbtRed := Round(total_red);
slo[to_x].rgbtGreen := Round(total_green);
slo[to_x].rgbtBlue := Round(total_blue);
if isAlpha then alo[to_x] := Round(total_alpha);
end;
end;
apng.Assign(bTmp);
bTmp.Free;
end;
Thanks a lot, Have a nice day!
Here is another version (It works very fast):
procedure CropPNG(Source: TPNGObject; Left, Top, Width, Height: Integer;
out Target: TPNGObject);
var
IsAlpha: Boolean;
Line: Integer;
begin
if (Source.Width < (Left + Width)) or (Source.Height < (Top + Height)) then
raise Exception.Create('Invalid position/size');
Target := TPNGObject.CreateBlank(Source.Header.ColorType,
Source.Header.BitDepth, Width, Height);
IsAlpha := Source.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA];
for Line := 0 to Target.Height - 1 do
begin
if IsAlpha then
CopyMemory(Target.AlphaScanline[Line],
Ptr(LongInt(Source.AlphaScanline[Line + Top]) + LongInt(Left)),
Target.Width);
CopyMemory(Target.Scanline[Line],
Ptr(LongInt(Source.Scanline[Line + Top]) + LongInt(Left * 3)),
Target.Width * 3);
end;
end;
Note: The above code is compatible with the newer pngimage Version 1.56+ (which supports the CreateBlank constructor)
Here is one sample code modified from a 'SlicePNG' ("This function slices a large PNG file (e.g. an image with all images for a toolbar) into smaller, equally-sized pictures") procedure found elsewhere:
procedure CropPNG(Source: TPNGObject; Left, Top, Width, Height: Integer;
out Target: TPNGObject);
function ColorToTriple(Color: TColor): TRGBTriple;
begin
Color := ColorToRGB(Color);
Result.rgbtBlue := Color shr 16 and $FF;
Result.rgbtGreen := Color shr 8 and $FF;
Result.rgbtRed := Color and $FF;
end;
var
X, Y: Integer;
Bitmap: TBitmap;
BitmapLine: PRGBLine;
AlphaLineA, AlphaLineB: pngimage.PByteArray;
begin
if (Source.Width < (Left + Width)) or (Source.Height < (Top + Height)) then
raise Exception.Create('Invalid position/size');
Bitmap := TBitmap.Create;
try
Bitmap.Width := Width;
Bitmap.Height := Height;
Bitmap.PixelFormat := pf24bit;
for Y := 0 to Bitmap.Height - 1 do begin
BitmapLine := Bitmap.Scanline[Y];
for X := 0 to Bitmap.Width - 1 do
BitmapLine^[X] := ColorToTriple(Source.Pixels[Left + X, Top + Y]);
end;
Target := TPNGObject.Create;
Target.Assign(Bitmap);
finally
Bitmap.Free;
end;
if Source.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then begin
Target.CreateAlpha;
for Y := 0 to Target.Height - 1 do begin
AlphaLineA := Source.AlphaScanline[Top + Y];
AlphaLineB := Target.AlphaScanline[Y];
for X := 0 to Target.Width - 1 do
AlphaLineB^[X] := AlphaLineA^[X + Left];
end;
end;
end;
Sample call:
var
Png: TPNGObject;
CroppedPNG: TPNGobject;
begin
PNG := TPNGObject.Create;
PNG.LoadFromFile('..\test.png');
CropPNG(PNG, 30, 10, 60, 50, CroppedPNG);
CroppedPNG.SaveToFile('..\croptest.png');
I've tried writing code to just load a png using libpng. It's pretty horrible to work with.
Try using imlib2 to take care of translating PNG files. it has a Delphi binding, apparently.
If if you get really stuck you could use Inage Magick's separate executable to do the image cropping.
Related
My code is doing strange thing when MoveMessage procedure takes max values(ScreenWidth and ScreenHeight). So the "Hello, world" string moves to the right down corner and doing strange thing, but the max and min values are set correctly.
Can someone tell me where is my mistake.
program HelloCrt;
uses crt;
const
Message = 'Hello, world!';
procedure GetKey(var code: integer);
var
c: char;
begin
c := Readkey;
if c = #0 then
begin
c := Readkey;
code := -ord(c);
end
else
code := ord(c);
end;
procedure ShowMessage(x, y: integer; msg: string);
begin
GotoXY(x, y);
write(msg);
GotoXY(1, 1);
end;
procedure HideMessage(x, y: integer; msg: string);
var
len, i: integer;
begin
len := Length(msg);
GotoXY(x, y);
for i := 1 to len do
write(' ');
GotoXY(1, 1);
end;
procedure MoveMessage(var x, y: integer; msg: string; dx, dy: integer);
begin
HideMessage(x, y, msg);
x := x + dx;
y := y + dy;
if x > (ScreenWidth - length(msg)) then
x := (ScreenWidth - length(msg) + 1);
if x < 1 then
x := 1;
if y > ScreenHeight then
y := ScreenHeight;
if y < 1 then
y := 1;
ShowMessage(x, y, msg);
end;
var
CurX, CurY: integer;
c: integer;
begin
clrscr;
CurX := (ScreenWidth - length(Message)) div 2;
CurY := ScreenHeight div 2;
ShowMessage(CurX, CurY, Message);
while true do
begin
Getkey(c);
if c > 0 then
break;
case c of
-75:
MoveMessage(CurX, CurY, Message, -1, 0);
-77:
MoveMessage(CurX, CurY, Message, 1, 0);
-72:
MoveMessage(CurX, CurY, Message, 0, -1);
-80:
MoveMessage(CurX, CurY, Message, 0, 1);
end
end;
clrscr;
end.
I don't know how to word the title correctly but I was wondering if there is any way for me to be able to clear a single space from the console instead of clearing the entire thing just to re-write it again? for example, say I was to draw out a 3 by 3 square with the numbers counting from 1-9 all the way down, is there a way for me to change the final 9 without clearing all the prior numbers. when I clear the entire console it creates a flicker effect which is very annoying. if you want to see an example of this in code here is the thing I plan to use it on:
program randomPath;
uses crt, sysutils;
type StrMultiArray = array of array of String;
var
finishedBoard : StrMultiArray;
size, i, j : integer;
regenerate : boolean;
function generateMap(size : integer) : StrMultiArray;
var
posx, posy, choice, counter : integer;
ongoing : boolean;
board : StrMultiArray;
begin
setLength(board, size, size);
for i := 0 to (size-1) do
begin
for j := 0 to (size-1) do
begin
board[i,j] := '#';
end;
end;
posx := (size div 2);
posy := (size div 2);
board[posx,posy] := ' ';
ongoing := true;
counter := 0;
while ongoing = true do
begin
choice := random(2);
if (choice = 0) then
begin
choice := random(2);
if (choice = 0) then
begin
if (posx > 0) then
begin
posx := posx - 1;
end;
end
else
begin
if (posx < size-1) then
begin
posx := posx + 1;
end;
end;
end
else
begin
choice := random(2);
if (choice = 0) then
begin
if (posy > 0) then
begin
posy := posy - 1;
end;
end
else
begin
if (posy < size-1) then
begin
posy := posy + 1;
end;
end;
end;
counter := counter + 1;
board[posx,posy] := ' ';
if counter = (size * 12) then
begin
ongoing := false;
end;
end;
generateMap := board;
end;
procedure printBoard(board : StrMultiArray; size : integer);
begin
textColor(Cyan);
write('+');
for i := 0 to (size-1) do
begin
write('-');
end;
writeLn('+');
for i := 0 to (size-1) do
begin
textColor(Cyan);
write('|');
textColor(White);
for j := 0 to (size-1) do
begin
if (board[i,j] = '#') then
begin
textBackground(White);
end;
if (board[i,j] = '#') then
begin
textBackground(Red);
end;
//write(board[i,j]);
write(' ');
textBackground(Black);
end;
textColor(Cyan);
writeLn('|');
end;
textColor(Cyan);
write('+');
for i := 0 to (size-1) do
begin
write('-');
end;
writeLn('+');
textColor(White);
end;
procedure movePlayer(board : StrMultiArray; size : integer);
var
ongoing : boolean;
posx, posy, prevx, prevy : integer;
input : char;
begin
ongoing := true;
posx := (size div 2);
posy := (size div 2);
while (ongoing = true) do
begin
board[posx,posy] := '#';
prevx := posx;
prevy := posy;
printBoard(board, size);
input := readKey();
clrScr();
case input of
'w' :
if (posx > 0) then
begin
if (board[posx-1,posy] = ' ') then
posx := posx - 1;
end;
'a' :
if (posy > 0) then
begin
if (board[posx,posy-1] = ' ') then
posy := posy - 1;
end;
's' :
if (posx < (size-1)) then
begin
if (board[posx+1,posy] = ' ') then
posx := posx + 1;
end;
'd' :
if (posy < (size-1)) then
begin
if (board[posx,posy+1] = ' ') then
posy := posy + 1;
end;
'x' :
begin
regenerate := false;
ongoing := false;
end;
else
ongoing := false;
end;
board[prevx,prevy] := ' ';
end;
end;
begin
size := 10;
regenerate := true;
randomize;
while (regenerate = true) do
begin
finishedBoard := generateMap(size);
movePlayer(finishedBoard, size);
end;
end.
I found a useful function in Pascal that allow you to select a position in the console to move the "cursor" to from which point you can write in that location. the function is called GoToXY(). documentation can be found here: https://www.freepascal.org/docs-html/rtl/crt/gotoxy.html.
I am trying to change a bit-map's pixel color if it's white. I wrote following code. But it's awfully slow!. i want to check if a pixel's color is white or not, and if it is white, change the color to black.
Can anybody suggest a better approach?
procedure TForm1.Button1Click(Sender: TObject);
var
BitMap1 : TBitmap;
X, Y, Size : Integer;
P: Cardinal;
begin
BitMap1 := TBitmap.Create;
bitMap1.LoadFromFile('image1.bmp');
for Y := 0 to Bitmap1.Height - 1 do
begin
for X := 0 to Bitmap1.width * size - 1 do
begin
p := BitMap1.Canvas.Pixels[X,Y];
if p = 255 then
BitMap1.Canvas.Pixels[X,Y] := 0;
end;
end;
Image1.Picture.Assign(BitMap1);
end;
For sure use the ScanLine property to access bitmap pixels since you're working with a large array of pixels where the Pixels access is slow. For replacing colors of your choice with support for 24-bit and 32-bit bitmaps, I would use something like this:
procedure ReplaceColor(ABitmap: TBitmap; ASource, ATarget: TColor);
type
TRGBBytes = array[0..2] of Byte;
var
I: Integer;
X: Integer;
Y: Integer;
Size: Integer;
Pixels: PByteArray;
SourceColor: TRGBBytes;
TargetColor: TRGBBytes;
const
TripleSize = SizeOf(TRGBBytes);
begin
case ABitmap.PixelFormat of
pf24bit: Size := TripleSize;
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('Bitmap must be 24-bit or 32-bit format!');
end;
for I := 0 to TripleSize - 1 do
begin
// fill the array of bytes with color channel values in BGR order,
// the same would do for the SourceColor from ASource parameter:
// SourceColor[0] := GetBValue(ASource);
// SourceColor[1] := GetGValue(ASource);
// SourceColor[2] := GetRValue(ASource);
// but this is (just badly readable) one liner
SourceColor[I] := Byte(ASource shr (16 - (I * 8)));
// the same do for the TargetColor array from the ATarget parameter
TargetColor[I] := Byte(ATarget shr (16 - (I * 8)));
end;
for Y := 0 to ABitmap.Height - 1 do
begin
// get a pointer to the currently iterated row pixel byte array
Pixels := ABitmap.ScanLine[Y];
// iterate the row horizontally pixel by pixel
for X := 0 to ABitmap.Width - 1 do
begin
// now imagine, that you have an array of bytes in which the groups of
// bytes represent a single pixel - e.g. the used Pixels array for the
// first 2 pixels might look like this for 24-bit and 32-bit bitmaps:
// Pixels [0][1][2] [3][4][5]
// 24-bit B G R B G R
// Pixels [0][1][2][3] [4][5][6][7]
// 32-bit B G R A B G R A
// from the above you can see that you'll need to multiply the current
// pixel iterator by the count of color channels to point to the first
// (blue) color channel in that array; and that's what that (X * Size)
// is for here; X is a pixel iterator, Size is size of a single pixel:
// X * 3 (0 * 3) (1 * 3)
// ⇓ ⇓
// Pixels [0][1][2] [3][4][5]
// 24-bit B G R B G R
// X * 4 (0 * 4) (1 * 4)
// ⇓ ⇓
// Pixels [0][1][2][3] [4][5][6][7]
// 32-bit B G R A B G R A
// so let's compare a BGR value starting at the (X * Size) position of
// the Pixels array with the SourceColor array and if it matches we've
// found the same colored pixel, if so then...
if CompareMem(#Pixels[(X * Size)], #SourceColor, TripleSize) then
// copy the TargetColor color byte array values to that BGR position
// (in other words, replace the color channel bytes there)
Move(TargetColor, Pixels[(X * Size)], TripleSize);
end;
end;
end;
And the usage:
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('d:\Image.bmp');
ReplaceColor(Bitmap, clWhite, clBlack);
Image1.Picture.Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
For pure GDI and bitmaps having at most 256 colors you might use the CreateMappedBmp function.
You should use scanlines for this. Example:
procedure ChangeWhiteToBlack(var Bitmap: TBitmap);
var
scanline: PRGBTriple;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbtBlue = 255) and (rgbtGreen = 255) and (rgbtRed = 255) then
FillChar(scanline^, sizeof(TRGBTriple), 0);
end;
inc(scanline);
end;
end;
end;
To try this:
procedure TForm5.FormCreate(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Desktop\test.bmp');
ChangeWhiteToBlack(bm);
bm.SaveToFile('C:\Users\Andreas Rejbrand\Desktop\test2.bmp');
finally
bm.Free;
end;
end;
Update: You need only a very minor modification of the code to make it work on 32-bit bitmaps instead:
procedure ChangeWhiteToBlack32(var Bitmap: TBitmap);
var
scanline: PRGBQuad;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf32bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbBlue = 255) and (rgbGreen = 255) and (rgbRed = 255) then
FillChar(scanline^, sizeof(TRGBQuad), 0);
end;
inc(scanline);
end;
end;
end;
In fact, you could do
procedure ChangeWhiteToBlack24(var Bitmap: TBitmap);
var
scanline: PRGBTriple;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbtBlue = 255) and (rgbtGreen = 255) and (rgbtRed = 255) then
FillChar(scanline^, sizeof(TRGBTriple), 0);
end;
inc(scanline);
end;
end;
end;
procedure ChangeWhiteToBlack32(var Bitmap: TBitmap);
var
scanline: PRGBQuad;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf32bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbBlue = 255) and (rgbGreen = 255) and (rgbRed = 255) then
FillChar(scanline^, sizeof(TRGBQuad), 0);
end;
inc(scanline);
end;
end;
end;
procedure ChangeWhiteToBlack(var Bitmap: TBitmap);
begin
case Bitmap.PixelFormat of
pf24bit: ChangeWhiteToBlack24(Bitmap);
pf32bit: ChangeWhiteToBlack32(Bitmap);
else
raise Exception.Create('Pixel format must be pf24bit or pf32bit.');
end;
end;
if you don't want to make a single procedure that works with both 24-bit and 32-bit bitmaps, as TLama did. [One benefit of having two separate procedures is that these short procedures are easier to read (and maintain).]
procedure TForm1.Button1Click(Sender: TObject);
var
BitMap1,
BitMap2 : TBitmap;
X, Y, Size : Integer;
P: Cardinal;
begin
BitMap1 := TBitmap.Create;
BitMap1.LoadFromFile('image1.bmp');
BitMap1.Transparent := true;
BitMap1.TransparentColor := clWhite; // old color
BitMap2 := TBitMap.Create;
BitMap2.Height := BitMap1.Height;
BitMap2.Width := BitMap1.Width;
BitMap2.Canvas.Brush.Color := clBlack; // new color
BitMap2.Canvas.FillRect(
Rect(
0,
0,
BitMap2.Width,
BitMap2.Height
)
);
BitMap2.Canvas.Draw(BitMap1);
Image1.Picture.Assign(BitMap2);
BitMap1.Free;
BitMap2.Freel
end;
private void btnLoad2_Click(object sender, System.EventArgs e)
{
Bitmap myBitmap= new Bitmap(openFileDialog1.FileName);
Bitmap myBitmap1 = new Bitmap("C:\\Documents and Settings\\Lalji\\Desktop\\image.png");
for (int x = 0; x < myBitmap.Width; x++)
{
for (int y = 0; y < myBitmap.Height; y++)
{
// Get the color of a pixel within myBitmap.
Color pixelColor = myBitmap.GetPixel(x, y);
string pixelColorStringValue =
pixelColor.R.ToString("D3") + " " +
pixelColor.G.ToString("D3") + " " +
pixelColor.B.ToString("D3") + ", ";
if (pixelColor.R.Equals(0) && pixelColor.G.Equals(0) && pixelColor.B.Equals(0))
{
//MessageBox.Show("black pixel");
}
else if (pixelColor.R.Equals(255) && pixelColor.G.Equals(255) && pixelColor.B.Equals(255))
{
//MessageBox.Show("white pixel");
myBitmap1.SetPixel(x, y, Color.White);
}
//switch (pixelColorStringValue)
//{
// case "255 255 255":
// {
// // white pixel
// MessageBox.Show("white pixel");
// break;
// }
// case "000 000 000,":
// {
// // black pixel
// MessageBox.Show("black pixel");
// break;
// }
//}
}
}
myBitmap1.Save("C:\\Documents and Settings\\Lalji\\Desktop\\image1.png");
MessageBox.Show("Process done");
}
It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 9 years ago.
I am trying to convert an image (lets say black and white) to a Matrix (where 0 = black and 1 = white)
i tried with this code :
procedure TForm1.Button1Click(Sender: TObject);
type
tab = array[1..1000,1..1000] of byte;
var i,j: integer;
s : string;
image : TBitmap;
t : tab;
begin
image := TBitmap.Create;
image.LoadFromFile('c:\image.bmp');
s := '';
for i := 0 to image.Height do
begin
for j := 0 to image.Width do
begin
if image.Canvas.Pixels[i,j] = clWhite then
t[i,j] := 0
else
t[i,j] := 1;
end;
end;
for i := 0 to image.Height do
begin
for j := 0 to image.Width do
begin
s:=s + IntToStr(t[i,j]);
end;
Memo1.Lines.Add(s);
s:='';
end;
end;
But it gave me wrong results.
Any Idea?
There are five bugs and two other issues in your code!
First,
for i := 0 to image.Height do
must be replaced by
for i := 0 to image.Height - 1 do
(why?) and similarly,
for j := 0 to image.Width do
must be replaced by
for j := 0 to image.Width - 1 do
Second, the Pixels array takes arguments [x, y], not [y, x]. Hence, you need to replace
image.Canvas.Pixels[i,j]
by
image.Canvas.Pixels[j,i]
Third, you wrote "0 = black and 1 = white" but obviously you do the opposite!
Fourth, you try to access t[0, 0], even though your matrix starts indexing at 1. Use array[0..1000,0..1000] of byte; to fix that.
Fifth, you have a memory leak (image isn't freed -- use try..finally).
Also, it is better to use dynamic arrays:
type
TByteMatrix = array of array of byte;
var
mat: TByteMatrix;
and you begin with
SetLength(mat, image.Height - 1, image.Width - 1);
if you want it to index [y, x], and opposite otherwise.
Finally, you should not use the Pixels property at all in this case, since it is terribly slow. Instead, use the Scanline property. See this or that or something else for more information.
Also, you will gain a lot of speed simply by adding Memo1.Lines.BeginUpdate before and Memo1.Lines.EndUpdate after the update of the memo control.
The following procedure converts the input ABitmap bitmap to a multidimensional AMatrix array of bytes, which represents pixels and where 0 value means white pixel and 1 means any other color:
type
TPixelMatrix = array of array of Byte;
procedure BitmapToMatrix(ABitmap: TBitmap; var AMatrix: TPixelMatrix);
type
TRGBBytes = array[0..2] of Byte;
var
I: Integer;
X: Integer;
Y: Integer;
Size: Integer;
Pixels: PByteArray;
SourceColor: TRGBBytes;
const
TripleSize = SizeOf(TRGBBytes);
begin
case ABitmap.PixelFormat of
pf24bit: Size := SizeOf(TRGBTriple);
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('ABitmap must be 24-bit or 32-bit format!');
end;
SetLength(AMatrix, ABitmap.Height, ABitmap.Width);
for I := 0 to TripleSize - 1 do
SourceColor[I] := Byte(clWhite shr (16 - (I * 8)));
for Y := 0 to ABitmap.Height - 1 do
begin
Pixels := ABitmap.ScanLine[Y];
for X := 0 to ABitmap.Width - 1 do
begin
if CompareMem(#Pixels[(X * Size)], #SourceColor, TripleSize) then
AMatrix[Y, X] := 0
else
AMatrix[Y, X] := 1;
end;
end;
end;
This procedure prints out the multidimensional AMatrix array of bytes to the AMemo memo box:
procedure ShowPixelMatrix(AMemo: TMemo; const AMatrix: TPixelMatrix);
var
S: string;
X: Integer;
Y: Integer;
begin
AMemo.Clear;
AMemo.Lines.BeginUpdate;
try
AMemo.Lines.Add('Matrix size: ' + IntToStr(Length(AMatrix[0])) + 'x' +
IntToStr(Length(AMatrix)));
AMemo.Lines.Add('');
for Y := 0 to High(AMatrix) do
begin
S := '';
for X := 0 to High(AMatrix[Y]) - 1 do
begin
S := S + IntToStr(AMatrix[Y, X]);
end;
AMemo.Lines.Add(S);
end;
finally
AMemo.Lines.EndUpdate;
end;
end;
And the usage of the above procedures:
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
PixelMatrix: TPixelMatrix;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('d:\Image.bmp');
BitmapToMatrix(Bitmap, PixelMatrix);
finally
Bitmap.Free;
end;
ShowPixelMatrix(Memo1, PixelMatrix);
end;
This extension of the above BitmapToMatrix procedure allows you to specify at which luminance level given by the AMinIntensity parameter will be pixels taken as non-white.
The more the AMinIntensity value is closer to 0, the more lighter pixels are treated as non-white. This allows you to work with a color intensity tolerance (e.g. to better recognize antialiased text):
procedure BitmapToMatrixEx(ABitmap: TBitmap; var AMatrix: TPixelMatrix;
AMinIntensity: Byte);
type
TRGBBytes = array[0..2] of Byte;
var
X: Integer;
Y: Integer;
Gray: Byte;
Size: Integer;
Pixels: PByteArray;
begin
case ABitmap.PixelFormat of
pf24bit: Size := SizeOf(TRGBTriple);
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('ABitmap must be 24-bit or 32-bit format!');
end;
SetLength(AMatrix, ABitmap.Height, ABitmap.Width);
for Y := 0 to ABitmap.Height - 1 do
begin
Pixels := ABitmap.ScanLine[Y];
for X := 0 to ABitmap.Width - 1 do
begin
Gray := 255 - Round((0.299 * Pixels[(X * Size) + 2]) +
(0.587 * Pixels[(X * Size) + 1]) + (0.114 * Pixels[(X * Size)]));
if Gray < AMinIntensity then
AMatrix[Y, X] := 0
else
AMatrix[Y, X] := 1;
end;
end;
end;
Memo lines position is decline, but your looping image.height first its will be result reverse in memo, to that try this code
procedure TForm1.Button1Click(Sender: TObject);
var i,j: integer;
s : string;
image : TBitmap;
begin
image := TBitmap.Create;
image.LoadFromFile('c:\image.bmp');
s := '';
for i := 0 to image.width-1 do
begin
for j := 0 to image.Height-1 do
begin
if image.Canvas.Pixels[i,j] = clWhite then
s := s+'0'
else
s := s+'1';
end;
memo1.Lines.Add(s);
s:='';
end;
end;
OK, I just installed a Tortoise git in my PC. And I'm quiet amuse about the water effect from its about page.
try to move your mouse cursor on the turtle picture from tortoise GIT - About
its more like we are playing out finger on a water.
Does anyone know how to do make that kind of water effect in Delphi ?
See Leonel Togniolli's "Water Effects" at efg's lab.
The ripple effect is based on 2D Water Effects in December 1999 Game Developer Magazine Article
.
The algorithm is described in here 2D Water, as mentioned by François and as a reference in the source code.
Leonel's implementation is partly based on the gamedev article the-water-effect-explained by Roy Willemse. Here is also pascal code.
There is one more Delphi example at efg's called "Ripple Project", a screen shot is shown below.
Please do the following :
01. Create a Delphi Unit named "WaterEffect.pas" and paste the following codes:
unit WaterEffect;
interface
uses
Winapi.Windows, System.SysUtils, Vcl.Graphics, Math;
const
DampingConstant = 15;
type
PIntArray = ^TIntArray;
TIntArray = array[0..16777215] of Integer;
PPIntArray = ^TPIntArray;
TPIntArray = array[0..16777215] of PIntArray;
PRGBArray = ^TRGBArray;
TRGBArray = array[0..16777215] of TRGBTriple;
PPRGBArray = ^TPRGBArray;
TPRGBArray = array[0..16777215] of PRGBArray;
TWaterDamping = 1..99;
TWaterEffect = class(TObject)
private
{ Private declarations }
FrameWidth: Integer;
FrameHeight: Integer;
FrameBuffer01: Pointer;
FrameBuffer02: Pointer;
FrameLightModifier: Integer;
FrameScanLine01: PPIntArray;
FrameScanLine02: PPIntArray;
FrameScanLineScreen: PPRGBArray;
FrameDamping: TWaterDamping;
procedure SetDamping(Value: TWaterDamping);
protected
{ Protected declarations }
procedure CalculateWater;
procedure DrawWater(ALightModifier: Integer; Screen, Distance: TBitmap);
public
{ Public declarations }
constructor Create;
destructor Destroy; override;
procedure ClearWater;
procedure SetSize(EffectBackgroundWidth, EffectBackgroundHeight: Integer);
procedure Render(Screen, Distance: TBitmap);
procedure Bubble(X, Y: Integer; BubbleRadius, EffectBackgroundHeight: Integer);
property Damping: TWaterDamping read FrameDamping write SetDamping;
end;
implementation
{ TWaterEffect }
const
RandomConstant = $7FFF;
procedure TWaterEffect.Bubble(X, Y: Integer; BubbleRadius, EffectBackgroundHeight: Integer);
var
Rquad: Integer;
CX, CY, CYQ: Integer;
Left, Top, Right, Bottom: Integer;
begin
if (X < 0) or (X > FrameWidth - 1) then X := 1 + BubbleRadius + Random(RandomConstant) mod (FrameWidth - 2 * BubbleRadius - 1);
if (Y < 0) or (Y > FrameHeight - 1) then Y := 1 + BubbleRadius + Random(RandomConstant) mod (FrameHeight - 2 * BubbleRadius - 1);
Left := -Min(X, BubbleRadius);
Right := Min(FrameWidth - 1 - X, BubbleRadius);
Top := -Min(Y, BubbleRadius);
Bottom := Min(FrameHeight - 1 - Y, BubbleRadius);
Rquad := BubbleRadius * BubbleRadius;
for CY := Top to Bottom do
begin
CYQ := CY * CY;
for CX := Left to Right do
begin
if (CX * CX + CYQ <= Rquad) then
begin
Inc(FrameScanLine01[CY + Y][CX + X], EffectBackgroundHeight);
end;
end;
end;
end;
procedure TWaterEffect.CalculateWater;
var
X, Y, XL, XR: Integer;
NewH: Integer;
P1, P2, P3, P4: PIntArray;
PT: Pointer;
Rate: Integer;
begin
Rate := (100 - FrameDamping) * 256 div 100;
for Y := 0 to FrameHeight - 1 do
begin
P1 := FrameScanLine02[Y];
P2 := FrameScanLine01[Max(Y - 1, 0)];
P3 := FrameScanLine01[Y];
P4 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
XL := Max(X - 1, 0);
XR := Min(X + 1, FrameWidth - 1);
NewH := (P2[XL] + P2[X] + P2[XR] + P3[XL] + P3[XR] + P4[XL] + P4[X] +
P4[XR]) div 4 - P1[X];
P1[X] := NewH * Rate div 256;
end;
end;
PT := FrameBuffer01;
FrameBuffer01 := FrameBuffer02;
FrameBuffer02 := PT;
PT := FrameScanLine01;
FrameScanLine01 := FrameScanLine02;
FrameScanLine02 := PT;
end;
procedure TWaterEffect.ClearWater;
begin
if FrameBuffer01 <> nil then ZeroMemory(FrameBuffer01, (FrameWidth * FrameHeight) * SizeOf(Integer));
if FrameBuffer02 <> nil then ZeroMemory(FrameBuffer02, (FrameWidth * FrameHeight) * SizeOf(Integer));
end;
constructor TWaterEffect.Create;
begin
inherited;
FrameLightModifier := 10;
FrameDamping := DampingConstant;
end;
destructor TWaterEffect.Destroy;
begin
if FrameBuffer01 <> nil then FreeMem(FrameBuffer01);
if FrameBuffer02 <> nil then FreeMem(FrameBuffer02);
if FrameScanLine01 <> nil then FreeMem(FrameScanLine01);
if FrameScanLine02 <> nil then FreeMem(FrameScanLine02);
if FrameScanLineScreen <> nil then FreeMem(FrameScanLineScreen);
inherited;
end;
procedure TWaterEffect.DrawWater(ALightModifier: Integer; Screen, Distance:
TBitmap);
var
DX, DY: Integer;
I, C, X, Y: Integer;
P1, P2, P3: PIntArray;
PScreen, PDistance: PRGBArray;
PScreenDot, PDistanceDot: PRGBTriple;
BytesPerLine1, BytesPerLine2: Integer;
begin
Screen.PixelFormat := pf24bit;
Distance.PixelFormat := pf24bit;
FrameScanLineScreen[0] := Screen.ScanLine[0];
BytesPerLine1 := Integer(Screen.ScanLine[1]) - Integer(FrameScanLineScreen[0]);
for I := 1 to FrameHeight - 1 do FrameScanLineScreen[i] := PRGBArray(Integer(FrameScanLineScreen[i - 1]) + BytesPerLine1);
begin
PDistance := Distance.ScanLine[0];
BytesPerLine2 := Integer(Distance.ScanLine[1]) - Integer(PDistance);
for Y := 0 to FrameHeight - 1 do
begin
PScreen := FrameScanLineScreen[Y];
P1 := FrameScanLine01[Max(Y - 1, 0)];
P2 := FrameScanLine01[Y];
P3 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
DX := P2[Max(X - 1, 0)] - P2[Min(X + 1, FrameWidth - 1)];
DY := P1[X] - P3[X];
if (X + DX >= 0) and (X + DX < FrameWidth) and (Y + DY >= 0) and (Y + DY < FrameHeight) then
begin
PScreenDot := #FrameScanLineScreen[Y + DY][X + DX];
PDistanceDot := #PDistance[X];
C := PScreenDot.rgbtBlue - DX;
if C < 0 then PDistanceDot.rgbtBlue := 0 else if C > 255 then PDistanceDot.rgbtBlue := 255 else
begin
PDistanceDot.rgbtBlue := C;
C := PScreenDot.rgbtGreen - DX;
end;
if C < 0 then PDistanceDot.rgbtGreen := 0 else if C > 255 then PDistanceDot.rgbtGreen := 255 else
begin
PDistanceDot.rgbtGreen := C;
C := PScreenDot.rgbtRed - DX;
end;
if C < 0 then PDistanceDot.rgbtRed := 0 else if C > 255 then PDistanceDot.rgbtRed := 255 else
begin
PDistanceDot.rgbtRed := C;
end;
end
else
begin
PDistance[X] := PScreen[X];
end;
end;
PDistance := PRGBArray(Integer(PDistance) + BytesPerLine2);
end;
end;
end;
procedure TWaterEffect.Render(Screen, Distance: TBitmap);
begin
CalculateWater;
DrawWater(FrameLightModifier, Screen, Distance);
end;
procedure TWaterEffect.SetDamping(Value: TWaterDamping);
begin
if (Value >= Low(TWaterDamping)) and (Value <= High(TWaterDamping)) then FrameDamping := Value;
end;
procedure TWaterEffect.SetSize(EffectBackgroundWidth, EffectBackgroundHeight: Integer);
var
I: Integer;
begin
if (EffectBackgroundWidth <= 0) or (EffectBackgroundHeight <= 0) then
begin
EffectBackgroundWidth := 0;
EffectBackgroundHeight := 0;
end;
FrameWidth := EffectBackgroundWidth;
FrameHeight := EffectBackgroundHeight;
ReallocMem(FrameBuffer01, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameBuffer02, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameScanLine01, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLine02, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLineScreen, FrameHeight * SizeOf(PRGBArray));
ClearWater;
if FrameHeight > 0 then
begin
FrameScanLine01[0] := FrameBuffer01;
FrameScanLine02[0] := FrameBuffer02;
for I := 1 to FrameHeight - 1 do
begin
FrameScanLine01[I] := #FrameScanLine01[I - 1][FrameWidth];
FrameScanLine02[I] := #FrameScanLine02[I - 1][FrameWidth];
end;
end;
end;
end.
In "uses" add "WaterEffect".
Add a "Timer" with "Enable" property and "Interval=25".
In "Private Declaration" add "Water: TWaterEffect;" and "FrameBackground: TBitmap;".
Define "var X:Integer;"
Define the following
procedure TMainForm.FormCreate(Sender: TObject);
begin
Timer01.Enabled := true;
FrameBackground := TBitmap.Create;
FrameBackground.Assign(Image01.Picture.Graphic);
Image01.Picture.Graphic := nil;
Image01.Picture.Bitmap.Height := FrameBackground.Height;
Image01.Picture.Bitmap.Width := FrameBackground.Width;
Water := TWaterEffect.Create;
Water.SetSize(FrameBackground.Width,FrameBackground.Height);
X:=Image01.Height;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
FrameBackground.Free;
Water.Free;
end;
procedure TMainForm.Image01MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Water.Bubble(X,Y,1,100);
end;
procedure TMainForm.Image01MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Water.Bubble(X,Y,1,100);
end;
procedure TMainForm.Timer01Timer(Sender: TObject);
begin
if Random(8)= 1 then
Water.Bubble(-1,-1,Random(1)+1,Random(500)+50);
Water.Render(FrameBackground,Image01.Picture.Bitmap);
with Image01.Canvas do
begin
Brush.Style:=bsClear;
font.size:=12;
Font.Style:=[];
Font.Name := 'Comic Sans MS';
font.color:=$e4e4e4;
Textout(190, 30, DateTimeToStr(Now));
end;
end;
Now Compile. I think you will get the required effect.
That effect is generated by applying certain numerical transformations to the image. They're defined in the CWaterEffect class, which you can inspect for yourself in the WaterEffect.cpp source file.