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
Related
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
I need to generate a gradient bitmap that displays a rainbow gradient between two colors which are chosen by a user. To generate a rainbow is easy. The code below I got from Wiki and slightly adapted it. It has the advantage of being fast and simple.
function TColor_Dialog.GiveRainbowColor (fraction: double): TAlphaColor;
var
m: Double;
r, g, b, mt: Byte;
begin
if fraction <= 0 then m := 0 else
if fraction >= 1 then m := 6
else m := fraction * 6;
mt := (round (frac (m) * $FF));
case Trunc (m) of
0: begin
R := $FF;
G := mt;
B := 0;
end;
1: begin
R := $FF - mt;
G := $FF;
B := 0;
end;
2: begin
R := 0;
G := $FF;
B := mt;
end;
3: begin
R := 0;
G := $FF - mt;
B := $FF;
end;
4: begin
R := mt;
G := 0;
B := $FF;
end;
5: begin
R := $FF;
G := 0;
B := $FF - mt;
end;
end; // case
Result := ColorToQuad (r, g, b);
end; // GiveRainbowColor //
Trouble with this algorithm is it can't show a partial rainbow between two colors. Well, of course it can but than you have to approach the fraction of each color and I don't like that solution. I tried decomposing the color into its r, g, b channels but that did not work. The reason is quite obvious by hindsight. Suppose you need a gradient between FF0000 and 0000FF. You'll have a red color transforming from FF->00 and a blue from 00->FF. However, there is no green (00FF00) which is clearly present in a rainbow gradient.
What I need is a gradient function that I can give two colors and a fraction and it generates a color. Can anyone point me to an article, algorithm or even code?
Update
NGLN's answer is the right answer for this question. Both he and Warren wondered what to do when a a color is not a bright color (a color containing a 0, a $FF and a value). I tried several angles: up/downscaling and HSL interpolation. I finally settled down for the last one as being the most simple.
Basically you have two colors: from and to. Use RGBtoHSL to extract the HSL parameters from each color: RGBtoHSL (col_from, hf, sf, lf). Next compute the hue, saturation and luminance between both colors and reconstruct a new color. This is what NGLN mentions in his update about hue, but if you generalise this principle you have a rainbow between any color.
function TColor_Dialog.interpolate_hsl (col_from, col_to: TAlphaColor; fraction: double): TAlphaColor;
var af, at, ad: uInt8;
hf, ht, hd: single;
sf, st, sd: single;
lf, lt, ld: single;
begin
// Get each rgb color channel
af := GetAValue (col_from);
at := GetAValue (col_to);
RGBtoHSL (col_from, hf, sf, lf);
RGBtoHSL (col_to, ht, st, lt);
// Compute differences
ad := af + Round (fraction * (at - af));
hd := hf + fraction * (ht - hf);
sd := sf + fraction * (st - sf);
ld := lf + fraction * (lt - lf);
Result := MakeColor (HSLtoRGB (hd, sd, ld), ad);
end; // interpolate_hsl //
This gives a rainbow for all colors possible. I apply the same interpolation for the opacity, hence the use of MakeColor to 'fumble' the interpolated alpha channel into the color.
Then you need to calculate the position of a color in the Rainbow; the inverse of GiveRainbowColor:
function RainbowIndex(BrightColor: TColor): Double;
var
R: Byte;
G: Byte;
B: Byte;
begin
R := GetRValue(ColorToRGB(BrightColor));
G := GetGValue(ColorToRGB(BrightColor));
B := GetBValue(ColorToRGB(BrightColor));
if (R * G * B <> 0) or ((R <> 255) and (G <> 255) and (B <> 255)) then
Result := -1
else if B = 0 then
if R = 255 then
Result := 0 + G / 255
else
Result := 1 + (255 - R) / 255
else if R = 0 then
if G = 255 then
Result := 2 + B / 255
else
Result := 3 + (255 - G) / 255
else { G = 0 }
if B = 255 then
Result := 4 + R / 255
else
Result := 5 + (255 - B) / 255;
Result := Result / 6;
end;
(But this displays a problem for colors not having both a 0 and a 255 part. In other words: you would also need to calculate the bright color from a shaded, tinted or grayed color. See update below.)
Example usage to get the rainbow slice from clRed to clBlue:
procedure TForm1.FormPaint(Sender: TObject);
var
Start: Double;
Finish: Double;
X: Integer;
begin
Start := RainbowIndex(clRed);
Finish := RainbowIndex(clBlue);
for X := 0 to ClientWidth - 1 do
begin
Canvas.Brush.Color := GiveRainbowColor(0, ClientWidth - 1, X);
Canvas.FillRect(Bounds(X, 0, 1, 50));
Canvas.Brush.Color :=
GiveRainbowColor(0, ClientWidth - 1, Round(Start + (Finish - Start) * X));
Canvas.FillRect(Bounds(X, 50, 1, 50));
end;
end;
Update:
The RainbowIndex routine above really does nothing more then calculate the hue property of the color. The GraphUtil unit provides conversion routines for the HSL color model which makes this RainbowIndex routine kind of obsolete and gives the advantage to be able to feed any TColor value:
uses
GraphUtil;
const
HLSMAX = 240;
function Hue(AColor: TColor): Double;
var
Hue: Word;
Luminance: Word;
Saturation: Word;
begin
ColorRGBToHLS(ColorToRGB(AColor), Hue, Luminance, Saturation);
Result := Hue / HLSMAX;
end;
Example usage to get the rainbow slice from clMoneyGreen to clPurple:
function RainbowColor(Hue: Double): TColor; overload;
begin
Hue := EnsureRange(Hue, 0, 1) * 6;
case Trunc(Hue) of
0: Result := RGB(255, Round(Frac(Hue) * 255), 0);
1: Result := RGB(255 - Round(Frac(Hue) * 255), 255, 0);
2: Result := RGB(0, 255, Round(Frac(Hue) * 255));
3: Result := RGB(0, 255 - Round(Frac(Hue) * 255), 255);
4: Result := RGB(Round(Frac(Hue) * 255), 0, 255);
else
Result := RGB(255, 0, 255 - Round(Frac(Hue) * 255));
end;
end;
function RainbowColor(MinHue, MaxHue, Hue: Integer): TColor; overload;
begin
Result := RainbowColor((Hue - MinHue) / (MaxHue - MinHue + 1));
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X: Integer;
Start: Double;
Finish: Double;
begin
Start := Hue(clMoneyGreen);
Finish := Hue(clPurple);
for X := 0 to ClientWidth - 1 do
begin
Canvas.Brush.Color := RainbowColor(0, ClientWidth - 1, X);
Canvas.FillRect(Bounds(X, 0, 1, 50));
Canvas.Brush.Color :=
RainbowColor(Start + (Finish - Start) * X / ClientWidth);
Canvas.FillRect(Bounds(X, 50, 1, 50));
end;
end;
Furthermore, the RainbowColor routine could be shortened to:
function RainbowColor(Hue: Double): TColor; overload;
begin
Result := ColorHLStoRGB(Round(Hue * HLSMAX), HLSMAX div 2, HLSMAX);
end;
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;
I need to change the value of the alpha component when a pixel contains a specific color for a TBitmap of 32 bits, I know about the ScanLine property to access the bitmap data, but i can't figure out how change the alpha component of each pixel.
This is a basic implementation
First you need define a record to hold the ARGB structure
TRGB32 = record
B, G, R, A: byte;
end;
Then you must define a array of TRGB32 to cast the Scanline and get and set the values.
Check this sample method
procedure SetAlphaBitmap(const Dest: TBitmap;Color : TColor;Alpha:Byte);
type
TRGB32 = record
B, G, R, A: byte;
end;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = array[0..0] of TRGB32;
var
x, y: integer;
Line, Delta: integer;
ColorRGB : TColor;
begin
if Dest.PixelFormat<>pf32bit then exit;
ColorRGB:=ColorToRGB(Color);
Line := integer(Dest.ScanLine[0]);
Delta := integer(Dest.ScanLine[1]) - Line;
for y := 0 to Dest.Height - 1 do
begin
for x := 0 to Dest.Width - 1 do
if TColor(RGB(PRGBArray32(Line)[x].R, PRGBArray32(Line)[x].G, PRGBArray32(Line)[x].B))=ColorRGB then
PRGBArray32(Line)[x].A := Alpha;
Inc(Line, Delta);
end;
end;
Also you can take a look to this unit that i wrote to manipulate 32 bit bitmaps
For each 32 bits pixel the highest byte contains the alpha value.
var
P: Cardinal;
Alpha: Byte;
...
begin
...
P := bmp.Canvas.Pixels[x, y]; // Read Pixel
P := P and $00FFFFFF or Alpha shl 24; // combine your desired Alpha with pixel value
bmp.Canvas.Pixels[x, y] := P; // Write back
...
end;
I would make the following tweaks to RRUZ's answer:
procedure SetAlphaBitmap(Dest: TBitmap; Color: TColor; Alpha: Byte);
type
TRGB32 = packed record
B, G, R, A: Byte;
end;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = array[0..0] of TRGB32;
var
x, y: Integer;
Line: PRGBArray32;
ColorRGB: Longint;
Red, Green: Blue: Byte;
begin
if Dest.PixelFormat <> pf32bit then Exit;
ColorRGB := ColorToRGB(Color);
Red := GetRValue(ColorRGB);
Green := GetGValue(ColorRGB);
Blue := GetBValue(ColorRGB);
for y := 0 to Dest.Height - 1 do
begin
Line := PRGBArray32(Dest.ScanLine[y]);
for x := 0 to Dest.Width - 1 do
begin
with Line[x] do
begin
if (R = Red) and (G = Green) and (B = Blue) then
A := Alpha;
end;
end;
end;
end;
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 :-).