converting a PNGImage to grayscale using delphi - delphi

hi there
here it is my code:
procedure TForm4.Button1Click(Sender: TObject);
var
png: TPNGImage;
data: PRGBQarray;
p: ^tagRGBQuad;
i, o: integer;
begin
png := TPNGImage.Create;
try
png.LoadFromFile('C:\Untitled.png');
for o := 1 to 100 do
begin
data:=png.Scanline[o];
for I := 1 to 400 do
begin
p := #data^[i];
p.rgbGreen := p.rgbBlue;
p.rgbRed := p.rgbGreen;
end;
end;
img.picture.Assign(png);
finally
png.Free;
end;
end;
it doesn't work and it makes the pic messy, I'm sure it's because of the rgbReserved.
what should i do?

This is how to greyify a bitmap. (And, yes, if you want to greyify a PNG, you first need to get the bitmap data out of it. I think the VCL will do this for you.)
type
PRGB32Array = ^TRGB32Array;
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGBQuad)-1] of TRGBQuad;
procedure MakeGrey(Bitmap: TBitmap);
var
w, h: integer;
y: Integer;
sl: PRGB32Array;
x: Integer;
grey: byte;
begin
Bitmap.PixelFormat := pf32bit;
w := Bitmap.Width;
h := Bitmap.Height;
for y := 0 to h - 1 do
begin
sl := Bitmap.ScanLine[y];
for x := 0 to w - 1 do
with sl[x] do
begin
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
rgbBlue := grey;
rgbGreen := grey;
rgbRed := grey;
end;
end;
end;
Sample usage:
procedure TForm4.Button1Click(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\Porträtt, litet, kvadratiskt.bmp');
MakeGrey(bm);
Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
end;

Andreas's answer will give you a good, fast approximation, but you'll lose some quality, because red, green and blue don't mix with equal intensities in the human eye. If you want to "get it right", instead of
grey := (rgbBlue + rgbGreen + rgbRed) div 3;
try this:
grey := round(rgbRed * .3) + round(rgbGreen * .59) + round(rgbBlue * .11);
You'll get a bit of a performance hit over the simple average, though it probably won't be noticeable unless you're on a very large image.

I know the question has already been answered but here is my 2c worth...
The following code comes from the PNGComponents package (PngFunctions.pas) produced by Thany.
//
//The Following code comes from the PNGComponents package from Thany...
//
procedure MakeImageGrayscale(Image: TPNGObject; Amount: Byte = 255);
procedure GrayscaleRGB(var R, G, B: Byte);
var
X: Byte;
begin
X := Round(R * 0.30 + G * 0.59 + B * 0.11);
R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
end;
var
X, Y, PalCount: Integer;
Line: Pointer;
PaletteHandle: HPalette;
Palette: array[Byte] of TPaletteEntry;
begin
//Don't do anything if the image is already a grayscaled one
if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA])
then begin
if Image.Header.ColorType = COLOR_PALETTE
then begin
//Grayscale every palette entry
PaletteHandle := Image.Palette;
PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
for X := 0 to PalCount - 1
do GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
Image.Palette := PaletteHandle;
end
else begin
//Grayscale every pixel
for Y := 0 to Image.Height - 1
do begin
Line := Image.Scanline[Y];
for X := 0 to Image.Width - 1
do GrayscaleRGB(PRGBLine(Line)^[X].rgbtRed, PRGBLine(Line)^[X].rgbtGreen, PRGBLine(Line)^[X].rgbtBlue);
end;
end;
end;
end;
There is a set of routines, that was originally published by the author of the PNGImage components, that can be found on Code Central that shows how to do other things like Alpha blending two images, rotation, overlay, etc. CodeCentral Link

This really should have been a comment to #Mason's routine to turn RGB into GreyScale, but since I don't know how to make a comment show code, I'm making it an answer instead.
This is how I do the conversion:
FUNCTION RGB2GRAY(R,G,B : BYTE) : BYTE; Register; ASSEMBLER;
ASM
IMUL EAX,19595
IMUL EDX,38470
IMUL ECX,7471
ADD EAX,EDX
ADD EAX,ECX
SHR EAX,16
END;
FUNCTION GreyScale(C : TColor) : TColor; Register; ASSEMBLER;
ASM
MOVZX EDX,AH
MOV ECX,EAX
SHR ECX,16
MOVZX EAX,AL
CALL RGB2GRAY
MOVZX EAX,AL
MOV AH,AL
SHL EAX,8
MOV AL,AH
END;
I don't know if it is NTSC formula or whatever, but they seem to work in my programs :-).

Related

Scan Line Out of Range Error for Bitmap. TJanDrawImage Component for a Paint-like Program

I am using the free JansDraw Components and when the executable runs, it throws AV error. I could locate the error to specifically the loop block of the code (not the initial block of assignment statements).
procedure TjanDrawImage.colorcircle(var bm:TBitmap;center:tpoint;radius,mode:integer);
var p,p0,p1:pbytearray;
dx,x,y,w,h,i,j,sum,c:integer;
cm,tm:tbitmap;
Rs,Rd:trect;
begin
x:=center.x;
y:=center.y;
w:=bm.width;
h:=bm.height;
cm:=tbitmap.create;
cm.width:=2*radius;
cm.height:=2*radius;
cm.PixelFormat :=FPixelFormat;
tm:=tbitmap.create;
tm.width:=2*radius;
tm.height:=2*radius;
tm.PixelFormat :=FPixelFormat;
tm.canvas.brush.color:=clblack;
tm.canvas.Ellipse (0,0,tm.width-1,tm.height-1);
tm.transparent:=true;
tm.TransparentColor :=clblack;
Rd:=rect(0,0,cm.width,cm.height);
Rs:=rect(x-radius,y-radius,x+radius,y+radius);
cm.canvas.CopyRect (Rd,bm.canvas,RS);
for j:=0 to cm.height-1 do begin
p:=cm.scanline[j];
if j>0 then p0:=cm.scanline[j-1];
if j<(h-1) then p1:=cm.scanline[j+1];
for i:=0 to cm.width-1 do begin
case mode of
0: //blue
begin
p[i*3+1]:=0;
p[i*3+2]:=0;
end;
1: //green
begin
p[i*3]:=0;
p[i*3+2]:=0;
end;
2: //red
begin
p[i*3]:=0;
p[i*3+1]:=0;
end;
3: //not blue
begin
p[i*3]:=0;
end;
4: //not green
begin
p[i*3+1]:=0;
end;
5: //not red
begin
p[i*3+2]:=0;
end;
6: //half blue
begin
p[i*3]:=p[i*3]*9 div 10;
end;
7: //half green
begin
p[i*3+1]:=p[i*3+1]*9 div 10;
end;
8: //half red
begin
p[i*3+2]:=p[i*3+2]*9 div 10;
end;
9:// darker
begin
p[i*3]:=round(p[i*3]*10 /11);
p[i*3+1]:=round(p[i*3+1]*10 / 11);
p[i*3+2]:=round(p[i*3+2]*10 /11);
end;
10:// lighter
begin
p[i*3]:=round(p[i*3]*11 / 10);
p[i*3+1]:=round(p[i*3+1]*11 / 10);
p[i*3+2]:=round(p[i*3+2]*11 / 10);
end;
11:// gray
begin
sum:=round((p[i*3]+p[i*3+1]+p[i*3+2])/ 3);
p[i*3]:=sum;
p[i*3+1]:=sum;
p[i*3+2]:=sum;
end;
12:// mix
begin
c:=p[i*3];
p[i*3]:=p[i*3+1];
p[i*3+1]:=p[i*3+2];
p[i*3+2]:=c;
end;
13://smooth
begin
if ((j>0) and (j<(h-1))and (i>0)and (i<(w-1))) then begin
p[i*3]:=round((p[(i-1)*3]+p[(i+1)*3]+p0[i*3]+p1[i*3]) /4);
p[i*3+1]:=round((p[(i-1)*3+1]+p[(i+1)*3+1]+p0[i*3+1]+p1[i*3+1]) /4);
p[i*3+2]:=round((p[(i-1)*3+2]+p[(i+1)*3+2]+p0[i*3+2]+p1[i*3+2]) / 4);
end;
end;
end;
end;
end;
cm.canvas.Draw (0,0,tm);
cm.transparent:=true;
cm.transparentcolor:=clwhite;
bm.Canvas.draw(x-radius,y-radius,cm);
cm.free;
tm.free;
end;
A linked question which is helpful is this - implementing scan line of bitmap corectly. It suggests to cast the pointers to NativeInt. The OP changed his code after answers, making it difficult to correlate old code with new code. I understand that my problem is due to some hard coded sequential access of pointers but I am really beginner to make sense of scan line or pointers. If you help me port this, these components will continue to be useful to everyone.
update after comment from #Renate Schaaf:
all the brush modes of the janDrawImage are working now, except for the below one. I was expecting a bigger problem but that didn't turn out to be the case. So modified the title of the question. #Renate Schaaf Can you please help fix the below one too. I tried but failed.
procedure TjanDrawImage.rimple(src,dst:tbitmap;amount:extended);
var ca,sa,a,dx,dy,r,rx,ry,sr,fr:extended;
w,h,x,y,cx,cy,i,j,c,ci:NativeInt;
p1,p2:pbytearray;
begin
w:=src.width;
h:=src.height;
cx:=w div 2;
cy:=h div 2;
if amount<1 then amount:=1;
fr:=cx/amount;
for y:=0 to h-1 do begin
p1:=src.ScanLine[y];
for x:=0 to w-1 do begin
dx:=x-cx;dy:=-(y-cx);
r:=sqrt(sqr(dx)+sqr(dy));
sr:=fr*sin(r/cx*amount*2*pi);
if (r+sr<cx) and (r+sr>0) then begin
a:=arctan2(dy,dx);
sincos(a,sa,ca);
i:=cx+round((r+sr)*ca);
j:=cy+round((r+sr)*sa);
p2:=dst.scanline[j];
c:=x*3;ci:=i*3;
p2[ci]:=p1[c];
p2[ci+1]:=p1[c+1];
p2[ci+2]:=p1[c+2];
end;
end;
end;
end;
When you do scanline operations, you always need to make sure that your pixel location is within the boundaries of your bitmap, particularly if you make geometric transformations.
So, in the last example you must clamp j to [0,h-1] and i to [0,w-1] using max(min(..)).
Also, you should set the size and pixelformat of src and dst to the same at the beginning.
I didn't really bother to find out what this ripple is supposed to do, but when I run an example it doesn't look like it's doing whatever it does right. For geometric transformations you need to work backwards, running through the pixels of the destination and figure out which pixel of the source needs to go there. Otherwise you end up with a destination that has holes, like here.
Edit:
Since I'm stuck with my project: I think this is the routine you really want to use. Note that I just switched the roles of src and dst and corrected some errors. It now adds a water ripple effect to the bitmap.
procedure rimple(src, dst: TBitmap; amount: extended);
var
ca, sa, a, dx, dy, r, sr, fr: extended;
w, h, x, y, cx, cy, i, j, c, ci: NativeInt;
p1, p2: pbytearray;
bits: integer;
begin
Assert(src.PixelFormat in [pf24bit, pf32bit],
'Device independent bitmap needed');
dst.PixelFormat := src.PixelFormat;
bits := 3;
if src.PixelFormat = pf32bit then
bits := 4;
w := src.width;
h := src.height;
dst.SetSize(w, h);
cx := w div 2;
cy := h div 2;
// in case somebody enters a negative amount
if abs(amount) < 1 then
amount := 1;
fr := cx / amount;
for y := 0 to h - 1 do
begin
// switched src and dst
p1 := dst.scanline[y]; // src.scanline[y];
for x := 0 to w - 1 do
begin
dx := x - cx;
// Corrected from dy:=-(y-cx)
dy := (y - cy);
r := sqrt(sqr(dx) + sqr(dy));
sr := fr * sin(r / cx * amount * 2 * pi);
// Omitted the following check
// if (r + sr < cx) and (r + sr > 0) then
begin
a := arctan2(dy, dx);
sincos(a, sa, ca);
i := max(min(cx + round((r + sr) * ca), w - 1), 0);
j := max(min(cy + round((r + sr) * sa), h - 1), 0);
// switched src and dst
p2 := src.scanline[j];
c := x * bits;
ci := i * bits;
p1[c] := p2[ci];
p1[c + 1] := p2[ci + 1];
p1[c + 2] := p2[ci + 2];
end;
end;
end;
end;

Show Error in Scanline When PixelFormat is pf8bit

I use this code to scan very fast Bitmap.
Everything is Ok When PixelFormat = pf24bit but my program only work with 256 image color and for this reason PixelFormat = pf8bit.
When PixelFormat = pf8bit this code show error.
var
w, h: Integer;
CurrRow, OffSet: Integer;
x: byte;
pRed, pGreen, pBlue: PByte;
begin
CurrRow := Integer(aBitmap.Scanline[0]);
OffSet := Integer(aBitmap.Scanline[1]) - CurrRow;
Result:= False;
for h := 0 to aBitmap.Height - 1 do
begin
for w := 0 to aBitmap.Width - 1 do
begin
pBlue := PByte(CurrRow + w * 3);
pGreen := PByte(CurrRow + w * 3 + 1);
pRed := PByte(CurrRow + w * 3 + 2);
end;
inc(CurrRow, OffSet);
end;
now I use this code to swap color but dont work because scanline dont check color
procedure ReplaceColor(aBitmap: TBitmap; swap1, swap2: TRGBQuad);
var
w, h, k: Integer;
pScanline: pByte;
Red, Green, Blue, palindex: Byte;
PalEntries: array[0..255] of TRGBQuad;
begin
if aBitmap.Palette <> 0 then
GetPaletteEntries(aBitmap.Palette, 0, 255, PalEntries);
for h := 0 to aBitmap.Height - 1 do
begin
pScanline := pByte(aBitmap.Scanline[h]);
for w := 0 to aBitmap.Width - 1 do
begin
Blue:= PalEntries[pScanline^].rgbBlue ;
Red:= PalEntries[pScanline^].rgbRed ;
Green:= PalEntries[pScanline^].rgbGreen ;
if (Blue = swap1.rgbBlue) and (Red = swap1.rgbRed) and
(Green = swap1.rgbGreen) then
begin
Blue := swap2.rgbBlue;
Green := swap2.rgbGreen;
Red := swap2.rgbRed;
end
else if (Blue = swap2.rgbBlue) and (Red = swap2.rgbRed) and
(Green = swap2.rgbGreen) then
begin
Blue := swap1.rgbBlue;
Green := swap1.rgbGreen;
Red := swap1.rgbRed;
end;
Inc(pScanline);
end;
end;
end;
The code fails for pf8bit because it is not written to handle pf8bit. It is written to handle pf24bit instead.
The code is expecting each scanline to consist of width number of 3-byte (24 bits) pixels containing the actual RGB values. But in pf8bit, each scanline contains 1-byte (8 bit) pixels which are indexes into the bitmap's color palette. You are not accounting for that at all.
Try something more like this instead:
var
w, h: Integer;
pScanline: PByte;
Red, Green, Blue: Byte;
PalEntries: array[0..255] of TRGBQuad;
begin
Result := False;
if aBitmap.Palette <> 0 then
GetPaletteEntries(aBitmap.Palette, 0, 255, PalEntries);
for h := 0 to aBitmap.Height - 1 do
begin
pScanline := PByte(aBitmap.Scanline[h]);
for w := 0 to aBitmap.Width - 1 do
begin
case aBitmap.PixelFormat of
pf8Bit: begin
Blue := PalEntries[pScanline^].rgbBlue;
Green := PalEntries[pScanline^].rgbGreen;
Red := PalEntries[pScanline^].rgbRed;
Inc(pScanline);
end;
pf24Bit: begin
Blue := PRGBTriple(pScanline).rgbtBlue;
Green := PRGBTriple(pScanline).rgbtGreen;
Red := PRGBTriple(pScanline).rgbtRed;
Inc(pScanline, SizeOf(TRGBTriple));
end;
// etc for other color depths...
end;
end;
end;
end;
You need to do some research on how bitmaps actually work, particularly in relation to the format of the scanlines at the various color depths.
Bitmaps overview

How can I change color from a PNG image from white to black in Delphi?

I am using TPNGList from Gustavo Daud version 1.4 in Delphi XE2
It is holding some PNG 256x256 images that I use as button images.
However there is a need to change the background color and the contrast of the image is not good.
So I have now White images for dark backgrounds.
I need to change them to Black for light backgrounds.
There is transparency and should be kept. There is only white pixels. But, a generic source to target function would be great either.
EDIT:
Following sugestion for "go for it" I have tried the following, but only get black or white boxes:
procedure PNGInvertWB(Image: TPngImage; AWhite: Boolean);
procedure WBInvertRGB(var R, G, B: Byte);
var
color: LongInt;
begin
if AWhite then
begin
if RGB(R, G, B) = clWhite then
begin
Color := ColorToRGB(clBlack);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
end;
end
else
begin
if RGB(R, G, B) = clBlack then
begin
Color := ColorToRGB(clWhite);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
end;
end;
end;
var
X, Y, PalCount: Integer;
Line: PRGBLine;
PaletteHandle: HPalette;
Palette: array[Byte] of TPaletteEntry;
begin
if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA]) then begin
if Image.Header.ColorType = COLOR_PALETTE then begin
PaletteHandle := Image.Palette;
PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
for X := 0 to PalCount - 1 do
WBInvertRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
Image.Palette := PaletteHandle;
end
else begin
for Y := 0 to Image.Height - 1 do begin
Line := Image.Scanline[Y];
for X := 0 to Image.Width - 1 do
WBInvertRGB(Line[X].rgbtRed, Line[X].rgbtGreen, Line[X].rgbtBlue);
end;
end;
end;
end;
I am calling this using this code:
procedure TDBNavigator.UpdateColor;
var
PNGImage: TPngImage;
HCColor : TColor;
procedure Invert(AImage: TImage; AWhite: boolean);
begin
ConvertToPNG(AImage.Picture.Graphic, PNGImage);
PNGInvertWB(PNGImage, not AWhite);
AImage.Picture.Graphic := PNGImage;
end;
begin
Color := ThemeManager.CurrentPallete.Color[FThemeColor];
HCColor := ThemeManager.CurrentPallete.HighContrast(FThemeColor);
if HCColor <> FCurrentColor then
begin
Invert(uiPrevious, HCColor = clWhite);
Invert(uiNext, HCColor = clWhite);
Invert(uiInsert, HCColor = clWhite);
Invert(uiPost, HCColor = clWhite);
Invert(uiCancel, HCColor = clWhite);
Invert(uiDelete, HCColor = clWhite);
Invert(uiRefresh, HCColor = clWhite);
FCurrentColor := HCColor;
end;
end;
Not sure which part is wrong. This is part of one component and I am trying to change the image that was assigned on design time. It was a PNG image that I have loaded, 256x256 with transparency.
I need to use that TImage, I know it is not a button. And probably there is components that do that. I need to make by myself because a specific library that I am using.
I got the PNGInvertWB idea from one of the Gustavo functions on PNGFunctions:
procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255);
So, I have no experience with images at all, what is wrong with this code?
This is how it looks like on the component where I have the images:
Original:
After:
I have used the following function from the PNGFunctions to try this:
procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255);
procedure GrayscaleRGB(var R, G, B: Byte);
var
X: Byte;
begin
X := Round(R * 0.30 + G * 0.59 + B * 0.11);
R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1));
end;
var
X, Y, PalCount: Integer;
Line: PRGBLine;
PaletteHandle: HPalette;
Palette: array[Byte] of TPaletteEntry;
begin
//Don't do anything if the image is already a grayscaled one
if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA]) then begin
if Image.Header.ColorType = COLOR_PALETTE then begin
//Grayscale every palette entry
PaletteHandle := Image.Palette;
PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette);
for X := 0 to PalCount - 1 do
GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue);
SetPaletteEntries(PaletteHandle, 0, PalCount, Palette);
Image.Palette := PaletteHandle;
end
else begin
//Grayscale every pixel
for Y := 0 to Image.Height - 1 do begin
Line := Image.Scanline[Y];
for X := 0 to Image.Width - 1 do
GrayscaleRGB(Line[X].rgbtRed, Line[X].rgbtGreen, Line[X].rgbtBlue);
end;
end;
end;
end;
Where I have changed the GrayscaleRGB, since it was getting each pixel and changing it to gray scale, so I believed I could change to black or white accordingly.
will be good to see what you have original a what you get after this code execute
and the question is:
Do you really be sure that color of whole background is equ to black or white or it is near black or near white?
Becouse you compare exact color RGB(R, G, B) = clWhite
try this
procedure WBInvertRGB(var R, G, B: Byte);
var
color: LongInt;
begin
if AWhite then
begin
if ((R>240) and (G>240) and (B>240)) then
begin
Color := ColorToRGB(clBlack);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
end;
end
else
begin
if ((R<15) and (G<15) and (B<15)) then
begin
Color := ColorToRGB(clWhite);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
end;
end;
end;
what you get after?
Then i suppose that this is becouse of transparency (change bottom left corner to some different color)
i do not know details about this png component and do not know if it have pixels property
but put this at the end of procedure
Line := Image.Scanline[Image.Height - 1];
Line[0].rgbtRed:= 5;
Line[0].rgbtGreen:= 5;
Line[0].rgbtBlue:= 5;
any change in result?
or you go inside palete code than full colors
put breakpoints and you will see where your code break
and add comment here if this is color palete -this make difference becouse you can not change color to white and another to black. You need three steeps one change white to e.g. red black to white and red to black

Delphi - gradial fade of bitmap edges

Any library/code to fade the edges of a bitmap in a gradient manner?
Something like this:
Edit: final code
Ok came up with this code after your example, it's ~10 times faster after optimization with scanlines. Ideally I think I should convert it to use a 32bit bitmap instead and modify the actual alpha layer, but this works for now, ty!
procedure FadeEdges(b: TBitmap; Depth, Start, Col: TColor);
Var f, x, y, i: Integer;
w,h: Integer;
pArrays: Array of pRGBArray;
xAlpha: Array of byte;
sR, sG, sB: Byte;
a,a2: Double;
r1,g1,b1: Double;
Lx,Lx2: Integer;
procedure AlphaBlendPixel(X, Y: Integer);
begin
pArrays[y,x].rgbtRed := Round(r1 + pArrays[y,x].rgbtRed * a2);
pArrays[y,x].rgbtGreen := Round(g1 + pArrays[y,x].rgbtGreen * a2);
pArrays[y,x].rgbtBlue := Round(b1 + pArrays[y,x].rgbtBlue * a2);
end;
procedure AlphaBlendRow(Row: Integer; Alpha: Byte);
Var bR, bG, bB, xA: Byte;
t: Integer;
s,s2: Double;
begin
s := alpha / 255;
s2 := (255 - Alpha) / 255;
for t := 0 to b.Width-1 do begin
bR := pArrays[Row,t].rgbtRed;
bG := pArrays[Row,t].rgbtGreen;
bB := pArrays[Row,t].rgbtBlue;
pArrays[Row,t].rgbtRed := Round(sR*s + bR*s2);
pArrays[Row,t].rgbtGreen := Round(sG*s + bG*s2);
pArrays[Row,t].rgbtBlue := Round(sB*s + bB*s2);
end;
end;
begin
b.PixelFormat := pf24bit;
// cache scanlines
SetLength(pArrays,b.Height);
for y := 0 to b.Height-1 do
pArrays[y] := pRGBArray(b.ScanLine[y]);
// pre-calc Alpha
SetLength(xAlpha,Depth);
for y := 0 to (Depth-1) do
xAlpha[y] := Round(Start + (255 - Start)*y/(Depth-1));
// pre-calc bg color
sR := GetRValue(Col);
sG := GetGValue(Col);
sB := GetBValue(Col);
// offsets
w := b.Width-Depth;
h := b.Height-Depth;
for i := 0 to (Depth-1) do begin
a := xAlpha[i] / 255;
a2 := (255 - xAlpha[i]) / 255;
r1 := sR * a;
g1 := sG * a;
b1 := sB * a;
Lx := (Depth-1)-i;
Lx2 := i+w;
for y := 0 to b.Height - 1 do begin
AlphaBlendPixel(Lx, y); // Left
AlphaBlendPixel(Lx2, y); // right
end;
end;
for i := 0 to (Depth-1) do begin
AlphaBlendRow((Depth-1)-i, xAlpha[i]); // top
AlphaBlendRow(i+(h), xAlpha[i]); // bottom
end;
SetLength(xAlpha,0);
SetLength(pArrays,0);
end;
Final result: (left = original, right = blended on hovering with a ListView)
edit: further speed improvements, twice as fast as original proc.
I can give you some code I wrote a couple of years ago to achieve this. It might be useful as a guide. The code is part of a class that manipulates a bitmap and this is the part that fades the left edge of the bitmap into a white background:
procedure TScreenShotEnhancer.FadeOutLeft(Position, Start: Integer);
var
X, Y: Integer;
F, N: Integer;
I: Integer;
begin
BeginUpdate;
try
N := Position;
for I := 0 to N - 1 do begin
X := Position - I - 1;
F := Round(Start + (255 - Start)*I/N);
for Y := 0 to Height - 1 do
AlphaBlendPixel(X, Y, clWhite, F);
end;
finally
EndUpdate;
end;
end;
The actual work is done in this method:
procedure TScreenShotEnhancer.AlphaBlendPixel(X, Y: Integer; Color: TColor;
Alpha: Byte);
var
backgroundColor: TColor;
displayColor: TColor;
dR, dG, dB: Byte;
bR, bG, bB: Byte;
sR, sG, sB: Byte;
begin
backgroundColor := Bitmap.Canvas.Pixels[X, Y];
bR := GetRValue(backgroundColor);
bG := GetGValue(backgroundColor);
bB := GetBValue(backgroundColor);
sR := GetRValue(Color);
sG := GetGValue(Color);
sB := GetBValue(Color);
dR := Round(sR * alpha / 255 + bR * (255 - alpha) / 255);
dG := Round(sG * alpha / 255 + bG * (255 - alpha) / 255);
dB := Round(sB * alpha / 255 + bB * (255 - alpha) / 255);
displayColor := RGB(dR, dG, dB);
Bitmap.Canvas.Pixels[X, Y] := displayColor;
end;

Paint PNG image on other PNG

How to merge two PNG's together? I know that you can't use PNGObject.Draw because it doesn't copy alpha transaperncy (I am not sure but it doesn't work anyway) so custom procedure/function is needed. I didn't come with empty hands, I have this procedure:
procedure MergePNGLayer(Layer1,Layer2: TPNGObject; Const aLeft,aTop:Integer);
var
x, y: Integer;
SL1, SL2, SLBlended : pRGBLine;
aSL1, aSL2, aSLBlended: PByteArray;
blendCoeff: single;
blendedPNG, Lay2buff: TPNGObject;
begin
blendedPNG:=TPNGObject.Create;
blendedPNG.Assign(Layer1);
Lay2buff:=TPNGObject.Create;
Lay2buff.Assign(Layer2);
SetPNGCanvasSize(Layer2,Layer1.Width,Layer1.Height,aLeft,aTop);
for y := 0 to Layer1.Height-1 do
begin
SL1 := Layer1.Scanline[y];
SL2 := Layer2.Scanline[y];
aSL1 := Layer1.AlphaScanline[y];
aSL2 := Layer2.AlphaScanline[y];
SLBlended := blendedPNG.Scanline[y];
aSLBlended := blendedPNG.AlphaScanline[y];
for x := 0 to Layer1.Width-1 do
begin
blendCoeff:=aSL1[x] * 100/255/100;
aSLBlended[x] := round(aSL2[x] + (aSL1[x]-aSL2[x]) * blendCoeff);
SLBlended[x].rgbtRed := round(SL2[x].rgbtRed + (SL1[x].rgbtRed-SL2[x].rgbtRed) * blendCoeff);
SLBlended[x].rgbtGreen := round(SL2[x].rgbtGreen + (SL1[x].rgbtGreen-SL2[x].rgbtGreen) * blendCoeff);
SLBlended[x].rgbtBlue := round(SL2[x].rgbtBlue + (SL1[x].rgbtBlue-SL2[x].rgbtBlue) * blendCoeff);
end;
end;
Layer1.Assign(blendedPNG);
Layer2.Assign(Lay2buff);
blendedPNG.Free;
Lay2buff.Free;
end;
But sadly it doesn't work how it should, it does the job but not right. When it merges empty image with loaded image, it works fine, but when both images aren't empty, it makes them loss transparancy.
procedure TForm1.FormClick(Sender: TObject);
var
PNG1, PNG2, PNG3, Dest: TPNGObject;
begin
PNG1 := TPNGObject.Create;
PNG2 := TPNGObject.Create;
PNG3 := TPNGObject.Create;
PNG1.LoadFromFile('Aero\TopLeft.png');//Width 10
PNG2.LoadFromFile('Aero\Top.png');//Width 200
PNG3.LoadFromFile('Aero\TopRight.png');//Width 10
Dest := TPNGObject.CreateBlank(COLOR_RGBALPHA, 16, 220, 10);
MergePNGLayer(Dest, PNG1, 0, 0);
MergePNGLayer(Dest, PNG2, 10, 0);
MergePNGLayer(Dest, PNG3, 210, 0);
Dest.SaveToFile('C:\OUT.PNG');
end;
Wanted result:
Actual result:
I am not sure if you can see differences between these imgaes, but you should open these in PNG editor software and you will see the difference. So I need other procedure to merge PNGs. I am using newest version of PNGImage by the way.
Thanks and have a good day!
This seems to work just fine:
procedure DrawPngWithAlpha(Src, Dest: TPNGObject; const R: TRect);
var
X, Y: Integer;
Alpha: PByte;
begin
Src.Draw(Dest.Canvas, R);
// I have no idea why standard implementation of TPNGObject.Draw doesn't apply transparency.
for Y := R.Top to R.Bottom - 1 do
for X := R.Left to R.Right - 1 do
begin
Alpha := #Dest.AlphaScanline[Y]^[X];
Alpha^ := Min(255, Alpha^ + Src.AlphaScanline[Y - R.Top]^[X - R.Left]);
end;
end;

Resources