change a bitmap's pixel colour - image

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");
}

Related

Convert image to matrix [closed]

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;

How to copy one PNG from other PNG?

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.

How to make a water effect on TImage or anything?

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.

Speed up procedure to resize a grid column

I have a procedure to auto-resize a column in a grid to accommodate for the largest string in that column. However when there's over 2,000 records in the grid, it takes a little too much time. Any tips on speeding this up?
//lstSKU = grid
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M: Integer;
X: Integer;
S: String;
R: TRect;
begin
M:= 20;
lstSKU.Canvas.Font.Assign(lstSKU.Font);
for X:= 1 to lstSKU.RowCount - 1 do begin
S:= lstSKU.Cells[ACol, X];
R:= Rect(0, 0, 20, 20);
DrawText(lstSKU.Canvas.Handle, PChar(S), Length(S), R,
DT_LEFT or DT_VCENTER or DT_CALCRECT);
if R.Right > M then
M:= R.Right;
end;
M:= M + 15;
lstSKU.ColWidths[ACol]:= M;
end;
Is this a standard TStringGrid/TDrawGrid?
You can iterate through using Canvas.TextWidth(S) instead to measure the content width of each cell, save the largest, add any padding, and then set the Grid.ColWidths[Col] := M;. This will trigger a single redraw if needed. (Basically what you're doing, without repeating the drawing operation 2001 times.)
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M, T: Integer;
X: Integer;
S: String;
begin
M := 20;
for X := 1 to lstSKU.RowCount - 1 do
begin
S:= lstSKU.Cells[ACol, X];
T := lstSKU.Canvas.TextWidth(S);
if T > M then
M := T;
end;
M := M + 15;
lstSKU.ColWidths[ACol] := M;
end;
If you want to set both width and height of the cell to accomodate larger fonts or something, use TextExtent instead of TextWidth; TextExtent returns a TSize, from which you can read Width and Height.
Although already answered, I'm posting the final code, which you can use with any string grid (TStringGrid). It resized 3,000 records with 27 columns in 2.3 seconds, as opposed to the prior 6.4 average.
//AGrid = Grid containing column to be resized
//ACol = Column index of grid to be resized
//AMin = Minimum column width
procedure ResizeCol(AGrid: TStringGrid; const ACol, AMin: Integer);
var
M, T: Integer; //M=Maximum Width; T=Current Text
X: Integer; //X=Loop Counter
begin
M:= AMin; //Begin with minimum width
AGrid.Canvas.Font.Assign(AGrid.Font);
for X:= 1 to AGrid.RowCount - 1 do begin
T:= AGrid.Canvas.TextWidth(AGrid.Cells[ACol, X]);
if T > M then M:= T;
end;
AGrid.ColWidths[ACol]:= M + AMin;
end;

drawn thumbnails in tlistbox

In DelphiXE, I'm using a tFileOpenDialog to select a folder and then listing all the *.jpg files in that folder in a tListBox. I'm allowing the list items to be dragged and dropped within the list for custom sorting so that I can display them in order later.
I'd like to be able to draw a thumbnail of the image beside the filename so that the display is similar to Windows Explorer when looking at files in List view where you have the associated icon just left of the file name on the same row.
I've found a couple of old examples that lead me to believe this is possible using tListBox.onDrawItem, but I've been unable to get one to work.
What is the best approach to take to accomplish this goal using a tListBox, or by some other means?
Thanks for your help.
Update: I've been working to use tListView instead, as suggested.
I've attempted to convert the examples from Ken and Andreas to use actual images instead of dynamically created sample bitmaps. I was able to get the basics working, but without resizing, I get only the top left of the image 64*64. I'm only working with JPGs at this point. imagecount is just the count of my list of filenames in my listbox, I haven't moved the initial list creation into the listview at this point.
That is done with this code:
procedure TfrmMain.CreateThumbnails;
var
i: Integer;
FJpeg: TJpegImage;
R: TRect;
begin
for i := 0 to imageCount - 1 do
begin
FJpeg := TJpegImage.Create;
thumbs[i] := TBitmap.Create;
FJpeg.LoadFromFile(Concat(imgFolderlabel.caption,
photoList.Items.Strings[i]));
thumbs[i].Assign(FJpeg);
thumbs[i].SetSize(64, 64);
end;
imgListView.LargeImages := ImageList1;
FJpeg.Free;
end;
In order to also resize and stretch the image properly within the thumbnail, I'm trying to implement some code from here: http://delphi.about.com/od/graphics/a/resize_image.htm
The new code looks like:
procedure TfrmMain.CreateThumbnails;
var
i: Integer;
FJpeg: TJpegImage;
R: TRect;
begin
for i := 0 to imageCount - 1 do
begin
FJpeg := TJpegImage.Create;
thumbs[i] := TBitmap.Create;
FJpeg.LoadFromFile(Concat(imgFolderlabel.caption,
photoList.Items.Strings[i]));
thumbs[i].Assign(FJpeg);
//resize code
R.Left := 0;
R.Top := 0;
// proportional resize
if thumbs[i].Width > thumbs[i].Height then
begin
R.Right := 64;
R.Bottom := (64 * thumbs[i].Height) div thumbs[i].Width;
end
else
begin
R.Bottom := 64;
R.Right := (64 * thumbs[i].Width) div thumbs[i].Height;
end;
thumbs[i].Canvas.StretchDraw(R, thumbs[i]);
// resize image
//thumbs[i].Width := R.Right;
//thumbs[i].Height := R.Bottom;
thumbs[i].SetSize(64, 64); //all images must be same size for listview
end;
imgListView.LargeImages := ImageList1;
FJpeg.Free;
end;
This gives me a collage of image thumbnails with their filenames and works good.
Thank you.
Not an answer, but an alternative (using Andreas' code for creating the image array as a starting point). Drop a TListView and a TImageList on a new form, cut all the code from the editor from the interface to just above the final end. with this:
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ComCtrls;
type
TForm1 = class(TForm)
ImageList1: TImageList;
ListView1: TListView;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
procedure CreateListItems;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
N = 50;
THUMB_WIDTH = 32;
THUMB_HEIGHT = 32;
THUMB_PADDING = 4;
var
thumbs: array[0..N-1] of TBitmap;
procedure CreateThumbnails;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
thumbs[i] := TBitmap.Create;
thumbs[i].SetSize(THUMB_WIDTH, THUMB_HEIGHT);
thumbs[i].Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
thumbs[i].Canvas.FillRect(Rect(0, 0, THUMB_WIDTH, THUMB_HEIGHT));
end;
end;
procedure TForm1.CreateListItems;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
with ListView1.Items.Add do
begin
Caption := 'Item ' + IntToStr(i);
ImageIndex := i;
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
var
i: Integer;
begin
CreateThumbnails;
for i := 0 to N - 1 do
ImageList1.Add(thumbs[i], nil);
ListView1.LargeImages := ImageList1;
CreateListItems;
end;
OnDrawItem is a good way to go.
Simple example:
const
N = 50;
THUMB_WIDTH = 64;
THUMB_HEIGHT = 64;
THUMB_PADDING = 4;
var
thumbs: array[0..N-1] of TBitmap;
procedure CreateThumbnails;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
thumbs[i] := TBitmap.Create;
thumbs[i].SetSize(THUMB_WIDTH, THUMB_HEIGHT);
thumbs[i].Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
thumbs[i].Canvas.FillRect(Rect(0, 0, THUMB_WIDTH, THUMB_HEIGHT));
end;
end;
procedure TForm4.FormCreate(Sender: TObject);
var
i: integer;
begin
with ListBox1.Items do
begin
BeginUpdate;
for i := 0 to N - 1 do
Add(Format('This is item %d.', [i]));
EndUpdate;
end;
ListBox1.ItemHeight := 2*THUMB_PADDING + THUMB_HEIGHT;
CreateThumbnails;
end;
procedure TForm4.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
dc: HDC;
s: string;
r: TRect;
begin
dc := TListBox(Control).Canvas.Handle;
s := TListBox(Control).Items[Index];
FillRect(dc, Rect, GetStockObject(WHITE_BRUSH));
BitBlt(dc,
Rect.Left + THUMB_PADDING,
Rect.Top + THUMB_PADDING,
THUMB_WIDTH,
THUMB_HEIGHT,
thumbs[Index].Canvas.Handle,
0,
0,
SRCCOPY);
r := Rect;
r.Left := Rect.Left + 2*THUMB_PADDING + THUMB_WIDTH;
DrawText(dc,
PChar(s),
length(s),
r,
DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);
end;
In a real-world scenario, the thumbs array would contain the actual image thumbs. In this example, however, the "thumbnails" consist of single-colour squares.

Resources