I having one Delphi XE2 Project to change Label01 Font Color using Timer04. So I have written the following codes:
procedure TMainForm.FormCreate(Sender: TObject);
begin
Timer04.Enabled := true;
end;
..
..
..
..
..
procedure TMainForm.Timer04Timer(Sender: TObject);
var
StartColor, RedColor, GreenColor, BlueColor: integer;
begin
StartColor := ColorToRGB(Label01.Font.Color);
RedColor := GetRValue(StartColor);
GreenColor := GetGValue(StartColor);
BlueColor := GetBValue(StartColor);
if RedColor <= 251 then Inc(RedColor, 1) else RedColor := 1;
if GreenColor <= 252 then Inc(GreenColor, 2) else GreenColor := 2;
if BlueColor <= 253 then Inc(BlueColor, 3) else BlueColor := 3;
Label01.Font.Color := RGB(RedColor, GreenColor, BlueColor);
end;
This codes work perfectly. Label01 Font Color changes between different colors.
Now I am trying to implement that Label02 Color will be fixed (say Green) and the value of brightnees will be increase from 0 to 100. If the value reaches to 100 it will be decreased to 0 and it will be continuous to a loop.
For my case I have chosen HUE=135, SATURATION=85 and BRIGHTNESS=50. The value of BRIGHTNESS will be increased from 50 to 100 and then will be decreased from 100 to 0 and it will be continued.
But the problem is that there is no such Function available to convert HSB to RGB and vice versa in Delphi XE2. I have Gooled it. But I have found any Function as HSBToRGB. Only some Delphi Unit is availabe. I have read their revoews and found that every one is having some bugs.
Here is a Delphi a translation of C code found here: http://www.cs.rit.edu/~ncs/color/t_convert.html
function RGBFP(R, G, B: Double): TColor;
const
RGBmax = 255;
begin
Result := RGB(Round(RGBmax * R), Round(RGBmax * G), Round(RGBmax * B));
end;
function HSVtoRGB(H, S, V: Double): TColor;
var
i: Integer;
f, p, q, t: Double;
begin
Assert(InRange(H, 0.0, 1.0));
Assert(InRange(S, 0.0, 1.0));
Assert(InRange(V, 0.0, 1.0));
if S = 0.0 then
begin
// achromatic (grey)
Result := RGBFP(V, V, V);
exit;
end;
H := H * 6.0; // sector 0 to 5
i := floor(H);
f := H - i; // fractional part of H
p := V * (1.0 - S);
q := V * (1.0 - S * f);
t := V * (1.0 - S * (1.0 - f));
case i of
0:
Result := RGBFP(V, t, p);
1:
Result := RGBFP(q, V, p);
2:
Result := RGBFP(p, V, t);
3:
Result := RGBFP(p, q, V);
4:
Result := RGBFP(t, p, V);
else
Result := RGBFP(V, p, q);
end;
end;
I've given this minimal testing. Please do feel free to double check it.
For Firemonkey it's HSLtoRGB from System.UIConsts.pas
It's similar to HSB (=HSV). All you can do with HSB you can do with HSL
function HSLtoRGB(H, S, L: Single): TAlphaColor;
It returns FMX TAlphaColor - that is RGB.
For VCL you need TColor, that is BGR.
So use RGBtoBGR in the same unit.
function RGBtoBGR(const C: TAlphaColor): TAlphaColor;
Then just do
Color := TColor(MyAlphaColorVariable);
AFAIK there is no HSB function in standard units.
Related
I would like to load an image, and read pixels to find a certain RGB, but then check the next pixels across to make sure they match, and i am at the right position of the bitmap.
I know the below code is wrong, but i am not sure how to go about correcting it. I also know Pixels is not the fastest way to read pixels.
Thanks guys!
procedure RGB(Col: TColor; var R, G, B: Byte);
var
Color: $0..$FFFFFFFF;
begin
Color := ColorToRGB(Col);
R := ($000000FF and Color);
G := ($0000FF00 and Color) Shr 8;
B := ($00FF0000 and Color) Shr 16;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
x,y : Integer;
ColorN: TColor;
R, G, B: Byte;
begin
for Y := 0 to Image1.Picture.Bitmap.Height -1 do
begin
for X := 0 to Image1.Picture.Bitmap.Width -1 do
begin
inc(i);
ColorN := Image1.Canvas.Pixels[x, y];
RGB(ColorN, R, G, B);
//Memo1.Lines.Append('Line: '+IntToStr(i)+' Y: '+IntToStr(Y)+' X: '+IntToStr(X)+' R: '+IntToStr(R)+' G: '+IntToStr(G)+' B: '+IntToStr(B));
if (IntToStr(R) = '235') and (IntToStr(G) = '235') and (IntToStr(B) = '235') then //Y: 500 X: 587
begin
//Image1.Canvas.MoveTo(X,Y);
//Image1.Canvas.LineTo(X,Y);
ColorN := Image1.Canvas.Pixels[x +1, y];
RGB(ColorN, R, G, B);
end;
if (IntToStr(R) = '232') and (IntToStr(G) = '232') and (IntToStr(B) = '232') then //RGB:232,232,232 Y: 500 X: 588
begin
ColorN := Image1.Canvas.Pixels[x +1, y];
RGB(ColorN, R, G, B);
ShowMessage('Test1');
end;
if (IntToStr(R) = '231') and (IntToStr(G) = '231') and (IntToStr(B) = '231') then //RGB: 231,231,231 Y: 500 X: 589
begin
ColorN := Image1.Canvas.Pixels[x +1, y];
RGB(ColorN, R, G, B);
ShowMessage('Test2');
end;
if (IntToStr(R) = '230') and (IntToStr(G) = '230') and (IntToStr(B) = '230') then //RGB: 230,230,230 Y: 500 X: 590
begin
ShowMessage('Test3');
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
b: TBitmap;
begin
Image1.Picture.LoadFromFile('E:\Delphi Projects\Detect(XE6)\screen\1.png');
b := TBitmap.Create;
b.Assign(Image1.Picture.Graphic);
Image1.Picture.bitmap := b;
FreeAndNil(b);
end;
There are several big issues in this code:
Instead of IntToStr(R) = '235' it would be much faster to just check R=235
Instead of checking R, G and B individually, it would be easier to just check if ColorN=C_Gray235 where C_Gray235 = #00EBEBEB;
For the application as a whole I'd use a single if:
if (GetPixel(x, y) = C_Gray235) and
(GetPixel(x+1, y) = C_Gray232) and
(GetPixel(x+2, y) = C_Gray231) and
(GetPixel(x+3, y) = C_Gray230) then
begin
//do stuff here
end;
please note that the for-loop should be for x := 0 to myBitmap.Width - 4 (there's no way for the if to succeed once you have less than 4 pixels left on the line. Actually you may even get an AV if you try to access them, depending on the way you get the pixels).
Now if the bitmap already is a 24-bit or 32-bit bitmap, you can improve the performance quite a bit by using Bitmap.ScanLine[iLine]...
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;