Saving ImgView32 transparent layers to PNG - delphi

I have problems saving an ImgView32 layer as a TRANSPARENT PNG.
I use the code from this question to do the saving.
However, the image saves with a white background.
Here is how I initialize my ImgView32, create a layer on it, and then draw a line on it:
procedure TputLine.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
imwidth: integer;
imheight: integer;
begin
imwidth := Iv1.Width;
imheight := Iv1.Height;
with iv1 do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;
end;
BL := TBitmapLayer.Create(iv1.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
except
BL.Free;
raise;
end;
end;
So iv1 is the name of my ImgView32.
Then I draw a line on it using this code:
var
bm32:TBitmapLayer;
...
begin
bm32:=(iv1.Layers[0] as TBitmapLayer).Bitmap;
bm32.canvas.pen.color:=clwhite;
bm32.canvas.brush.color:=clwhite;
bm32.canvas.rectangle(0,0,bm32.width-1, bm32.height-1);
bm32.canvas.Pen.Color:=WinColor(ColorPickerGTK1.SelectedColor);
bm32.canvas.brush.color:=clWhite;
bm32.Canvas.Pen.Width:=3;
bm32.Canvas.MoveTo(0,bm32.Height);
bm32.Canvas.LineTo(0+150,bm32.Height-250);
end;
If I use the clWhite32 for the above code when drawing the rectangle, then when saving the PNG, the background of the imgView turns black... So I do not understand the problem really.
I do the saving like this:
procedure TputLine.Button2Click(Sender: TObject);
var
myLay:TBitmapLayer;
begin
mylay := iv1.Layers.Items[0] as TBitmapLayer;
SavePNGTransparentX(mylay.Bitmap);
end;
and the actual saving code (from the link described above)
procedure TPutLine.SavePNGTransparentX(bm32:TBitmap32);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
if IsWhite(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32(255,255,255,0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(bm32);
Png.SaveToFile('C:\ThisShouldBeTransparent.png');
Png.Free;
end;
I do not understand why it does not save the layer as transparent PNG.
How can I fix it? Any idea is welcome.
You can replicate my problem using the above code. It uses GR32_PNG and GR32_PortableNetworkGraphic. You only need to add a TImgView32 control to your form and add the code listed above.

The reason to the problem seems to be two-fold.
First, when you call Png.Assign(bm32); in unit GR32_PNG, it attempts to find out what the smallest format would be to store the image in. If the image has less than 256 distinct colors, it creates a paletted format, and depending on how many colors it finds, the bit depth can become 1, 2, 4 or 8. As far as my knowledge goes, only images with TrueColor and Alpha can be saved as variable transparency png images.
Secondly, you draw with only one color, which triggers the above problem. This is of course not your fault, IMO the above mentioned analysis should be possible to bypass.
The TPortableNetworkGraphic32 class has two properties, BitDepth and ColorType wich control the format of the png image, that would be useful, if they were settable! Attempting to set them in code as:
Png.BitDepth := 8;
Png.ColorType := ctTrueColorAlpha;
leads to exceptions
EPngError with message 'Bit depth may not be specified directly yet!
EPngError with message 'Color Type may not be specified directly yet!
From the wording we can assume some further development in the future.
The cure
To bypass the above described image analysis, you can change line 459 in GR32_PNG.pas.
procedure TPortableNetworkGraphic32.AssignPropertiesFromBitmap32()
var
...
begin
...
IsPalette := True; // <--- change to False
...
That will take care of the bit depth analysis and prevents palette creation if less than 256 colors.
After this hack you can use the SavePNGTransparentX() procedure to save a TBitmap32 to a .png file and preserving transparency.
Then, there's one change more that you may be interested in, regarding the SavePNGTransparentX() procedure. As you have seen, it requires the background of your drawing surface to be white, because it specifically sets the Alpha channel to zero for all white pixels. A TBitmapLayer is however initialized with all pixels (RGBA) as all zeros, so the color components of each pixel makes up to black color (which is not visible because the alpha channel is zero). Therefore you need to fill the drawing layer with white, which makes it opaque, which again covers up all lower layers (beneath the drawing layer).
To make a correction to this you can
remove the initialization of the drawing layer to all white
change the IsWhite function into an IsBlack function
change the assignment of the transparent pixels
Code would become
procedure TForm8.SavePNGTransparentX(bm32:TBitmap32);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(bm32);
Png.SaveToFile('C:\tmp\imgs\ThisShouldBeTransparent3.png');
Png.Free;
end;
With this change you can see the layers beneath your drawing layer and the resulting file of your drawing layer will have all non-drawn pixels transparent.
There is however still one problem in general with the above procedure, and that is that partially transparent pixels loose their transparency, but that will remain for a future excercise.
Here's a few images, First the ImageView with a bitmap loaded on the bottom layer:
Then, I draw a blue cross on the BL layer (ref. your code) using basically the code in your Button1Click() but without the white rectangle.
Then I save the BL layer to a .png file and look at it with Windows Explorer "Preview":

Related

Saving transparent (alpha channel) PNG from TImageList

I have a TImageList which contains transparent icons (32bit, with alpha channel). What I want to do is to save individual icons based on image index as PNG file(s), while preserving alpha channel transparency. Using RAD Studio 2010 so it has TPngImage support, no need for third party libraries. Images are loaded into TImageList from PNG "sprite" image using the method here - Add a png image to a imagelist in runtime using Delphi XE - so the transparency is preserved upon loading. Now I need to save them out individually, in other words, extract individual images from sprite images which is already loaded into TImageList.
My code so far:
int imageindex = 123;
boost::scoped_ptr<TPngImage> png(new TPngImage);
boost::scoped_ptr<Graphics::TBitmap> bmp(new Graphics::TBitmap);
MyImageList->GetBitmap(imageindex, bmp.get()); // Using GetBitmap to copy TImageList image into separate TBitmap
png->Assign(bmp.get()); // Assign that bitmap to TPngImage
png->SaveToFile("C:\\filename.png");
The above works but it saves with the white background (transparency is not preserved after saving). I am probably missing a simple step but can't figure it out.
Delphi code is also welcome, shouldn't be hard to translate.
Yes, you can obtain PNG-image from TImageList where it was added. Code below allows you to do this!
Firstly, add PngImage to your uses clause.
procedure LoadPNGFromImageList(AImageList: TCustomImageList; AIndex: Integer; var ADestPNG: TPngImage);
const
PixelsQuad = MaxInt div SizeOf(TRGBQuad) - 1;
type
TRGBAArray = Array [0..PixelsQuad - 1] of TRGBQuad;
PRGBAArray = ^TRGBAArray;
var
ContentBmp: TBitmap;
RowInOut: PRGBAArray;
RowAlpha: PByteArray;
X: Integer;
Y: Integer;
begin
if not Assigned(AImageList) or (AIndex < 0) or
(AIndex > AImageList.Count - 1) or not Assigned(ADestPNG)
then
Exit;
ContentBmp := TBitmap.Create;
try
ContentBmp.SetSize(ADestPNG.Width, ADestPNG.Height);
ContentBmp.PixelFormat := pf32bit;
// Allocate zero alpha-channel
for Y:=0 to ContentBmp.Height - 1 do
begin
RowInOut := ContentBmp.ScanLine[Y];
for X:=0 to ContentBmp.Width - 1 do
RowInOut[X].rgbReserved := 0;
end;
ContentBmp.AlphaFormat := afDefined;
// Copy image
AImageList.Draw(ContentBmp.Canvas, 0, 0, AIndex, true);
// Now ContentBmp has premultiplied alpha value, but it will
// make bitmap too dark after converting it to PNG. Setting
// AlphaFormat property to afIgnored helps to unpremultiply
// alpha value of each pixel in bitmap.
ContentBmp.AlphaFormat := afIgnored;
// Copy graphical data and alpha-channel values
ADestPNG.Assign(ContentBmp);
ADestPNG.CreateAlpha;
for Y:=0 to ContentBmp.Height - 1 do
begin
RowInOut := ContentBmp.ScanLine[Y];
RowAlpha := ADestPNG.AlphaScanline[Y];
for X:=0 to ContentBmp.Width - 1 do
RowAlpha[X] := RowInOut[X].rgbReserved;
end;
finally
ContentBmp.Free;
end;
end;
Look at the picture. It is depicts what will happen if we set or not set such line of code:
ContentBmp.AlphaFormat := afIgnored;
Figure 1 is a result of setting afIgnored and the second one figure is a result of not setting afIgnored, allowing to use previously set afDefined.
Original image is an image named Figure 1
Using of code above in application:
procedure TForm1.aButton1Click(Sender: TObject);
var
DestPNG: TPngImage;
begin
DestPNG := TPNGImage.Create;
try
// Initialize PNG
DestPNG.CreateBlank(COLOR_RGBALPHA, 8, 60, 60);
// Obtain PNG from image list
LoadPNGFromImageList(ImageList1, 0, DestPNG);
// Output PNG onto Canvas
DestPNG.Draw(Canvas, Rect(0, 0, 60, 60));
DestPNG.SaveToFile('C:\MyPNGIcon.png');
finally
DestPNG.Free;
end;
end;

Delphi FMX TImage manual alpha transparency mapping failure

I am trying to create a TImage with alpha transparency using code.
In this example, an anti-aliased circle.
I create an 8bit opacity map for the circle and then apply it to the TImage's TBitmap using this piece of code:
type
TOpacityMap = Array[0..4095] of PByteArray;
procedure DrawAntiAliasedCircle(srcBitmap: TBitmap; FillColor : TAlphaColor; CenterX, CenterY, Radius, LineWidth, Feather: single);
var
FillR : Integer;
FillG : Integer;
FillB : Integer;
FillRGB : Integer;
OpacityMap : TOpacityMap;
AlphaScanLine : Array[0..4095] of TAlphaColor;
bitmapData : FMX.Graphics.TBitmapData;
tmpScanLine : Pointer;
X,Y : Integer;
tmpMS : TMemoryStream;
begin
{Initialization}
FillR := TAlphaColorRec(FillColor).R;
FillG := TAlphaColorRec(FillColor).G;
FillB := TAlphaColorRec(FillColor).B;
CreateAntiAliasedCircleOpacityMap(OpacityMap, srcBitmap.Width, srcBitmap.Height, CenterX, CenterY, Radius, LineWidth, Feather);
{create image based on opacity map and free memory}
If srcBitmap.Map(TMapAccess.Write, bitmapData) then
try
FillRGB := (FillR shl 16)+(FillG shl 8)+FillB;
for Y := 0 to srcBitmap.Height-1 do
begin
for X := 0 to srcBitmap.Width-1 do
AlphaScanLine[X] := (OpacityMap[Y][X] shl 24)+FillRGB; // Opacity
tmpScanLine := bitmapData.GetScanline(Y);
AlphaColorToScanLine(#AlphaScanLine,tmpScanLine,srcBitmap.Width,srcBitmap.PixelFormat);
FreeMem(OpacityMap[Y]);
end;
finally
srcBitmap.Unmap(bitmapData);
end;
// Work-around fix
{tmpMS := TMemoryStream.Create;
srcBitmap.SaveToStream(tmpMS);
srcBitmap.LoadFromStream(tmpMS);
tmpMS.Free;}
end;
The result is the image on the left.
The actual TBitmap seems to be good, calling "srcBitmap.SaveToFile('circle.png')" results in a PNG file with a valid alpha channel.
I can work-around this issue by simply saving/loading the bitmap using a TMemoryStream.
How do I get the desired image on the right without the performance penalty of passing the image through a TMemoryStream?
These screenshots are from the minimal example project demonstrating this issue :
https://github.com/bLightZP/AntiAliasedCircle
edit #1 :
The github code linked above has been updated with an optimized (about 25% faster) version of Tom Brunberg's suggested fix.
You can achieve your goal with applying alpha channel premultiplying to your overlay image. For example in the loop where you add the alpha channel:
for X := 0 to srcBitmap.Width-1 do
begin
AlphaScanLine[X] := (OpacityMap[Y][X] shl 24)+FillRGB;
AlphaScanLine[X] := PremultiplyAlpha(AlphaScanLine[X]); // Add this for premultiplied Alpha
end;
The result looks like this (ofcourse without the stream work-around)

Blending semi-transparent bitmaps containing text with Graphics32

I'm trying to implement a layered painting system inside one of our internal components and I have problems blending bitmaps containing text.
Following code fragment shows the problem:
uses
GR32;
procedure DrawBitmaps;
var
bmp1: TBitmap32;
bmp2: TBitmap32;
begin
bmp1 := TBitmap32.Create;
bmp1.Width := 100;
bmp1.Height := 100;
bmp1.FillRect(0, 0, 100, 100, clWhite32);
bmp1.FillRect(0, 0, 80, 80, clTrGreen32);
bmp1.Font.Size := -16;
bmp1.Font.Color := clBlack;
bmp1.TextOut(2, 10, 'Green');
bmp1.SaveToFile('c:\0\bmp1.bmp');
bmp2 := TBitmap32.Create;
bmp2.Width := 80;
bmp2.Height := 80;
bmp2.FillRect(0, 0, 80, 80, clTrRed32);
bmp2.Font.Size := -16;
bmp2.Font.Color := clBlack;
bmp2.TextOut(2, 50, 'Red');
bmp2.SaveToFile('c:\0\bmp2.bmp');
bmp2.DrawMode := dmBlend;
bmp2.DrawTo(bmp1, 20, 20);
bmp1.SaveToFile('c:\0\bmpcombined.bmp');
bmp1.Free;
bmp2.Free;
end;
Resulting images:
bmp1:
bmp2:
bmpcombined:
As you can see, text is painted in black on bmp and bmp2, but appears white on bmpcombined.
I'm guessing the problem lies in TextOut which maps to Windows.ExtTextOut (via GR32_Backends_VCL.pas, TGDIBackend.Textout). That method doesn't handle transparency and paints text with alpha 00 (color is $000000 instead of $FF000000).
As a quick fix, setting bmp2.Font.Color to $FF000000 doesn't help.
bmp2.Font.Color := TColor(clBlack32);
I am using fresh sources from GitHub
How should I paint a non-transparent text on a semi-transparent background so that I could blend this into a larger picture?
As far as I remember the TextOut function was only meant as a direct way to add some text to the bitmap, lacking all the fixes you mentioned above.
In order to remain full control over transparency you might want to use
procedure TBitmap32.RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);
instead.
It uses the techniques you mentioned in your own answer, but on a more sophisticated level. It also allows you to use anti-aliasing (based on oversampling), but today it's not actually recommended to use any other anti-aliasing technique other than what the font-engine outputs (to take full advantage of font-hinting).
As you are using the latest source code you could also consider to use VPR to render the text (see example 'TextVPR'). It converts the outline of the text as vectors and use the vector drawing capabilities of Graphics32 (by default the engine 'VPR' is used, hence the name) to render it onto the screen. There's also a stripped down engine of AGG included, which itself is based on the FreeType1 engine, which might be slightly faster for fonts.
Speaking of performance: Keep in mind that every other approach than TextOut will obviously decrease the performance. So if you aim for high performance might better cook your own code (based on TextOut).
Otherwise the TextVPR approach leaves you with more freedom, especially when it comes to filling the text (with a gradient for example) or transforming the text (to a curve or such).
The best solution I could find requires three helper functions.
TransparentToOpaque changes all fully transparent pixels to opaque.
procedure TransparentToOpaque(bmp: TCustomBitmap32);
var
I: Integer;
D: PColor32Entry;
begin
D := PColor32Entry(#bmp.Bits[0]);
for I := 0 to bmp.Width * bmp.Height - 1 do begin
if D.A = 0 then
D.A := $FF;
Inc(D);
end;
bmp.Changed;
end;
FlipTransparency changes all fully transparent pixels to opaque and vice versa.
procedure FlipTransparency(bmp: TCustomBitmap32);
var
I: Integer;
D: PColor32Entry;
begin
D := PColor32Entry(#bmp.Bits[0]);
for I := 0 to bmp.Width * bmp.Height - 1 do begin
if D.A = 0 then
D.A := $FF
else if D.A = $FF then
D.A := 0;
Inc(D);
end;
bmp.Changed;
end;
MakeOpaque marks all pixels as opaque.
procedure MakeOpaque(bmp: TCustomBitmap32);
var
I: Integer;
D: PColor32Entry;
begin
D := PColor32Entry(#bmp.Bits[0]);
for I := 0 to bmp.Width * bmp.Height - 1 do begin
D.A := $FF;
Inc(D);
end;
bmp.Changed;
end;
Following tricks can then be applied.
After drawing text on the main image bmp1 which doesn't contain transparent pixels, code calls TransparentToOpaque to prevent problems with blending later on.
When drawing on a (semi)transparent bitmap bmp2, code creates yet another bitmap bmp3 and fills it with an opaque version of that (semi)transparent bitmap. This will ensure that font is aliased to correct colors in the TextOut call.
After the TextOut bmp3 contains opaque background and transparent text. FlipTransparency is then called to generate opaque text on a transparent background.
bmp3 is blended onto bmp2. This gives up opaque text on a (semi)transparent background.
bmp2 is blended onto bmp1.
Example code:
procedure TForm53.DrawBitmaps;
var
bmp1: TBitmap32;
bmp2: TBitmap32;
bmp3: TBitmap32;
begin
bmp1 := TBitmap32.Create;
bmp1.Width := 100;
bmp1.Height := 100;
bmp1.FillRect(0, 0, 100, 100, clWhite32);
bmp1.FillRect(0, 0, 80, 80, clTrGreen32);
bmp1.Font.Size := -16;
bmp1.Font.Color := clBlack;
bmp1.TextOut(2, 10, 'Green');
//Mark all fully transparent pixels (generated with TextOut) as opaque.
TransparentToOpaque(bmp1);
SaveBitmap32ToPNG(bmp1, 'c:\0\bmp1a.png');
bmp2 := TBitmap32.Create;
bmp2.Width := 80;
bmp2.Height := 80;
bmp2.FillRect(0, 0, 80, 80, clTrRed32);
//Create bitmap, large enough to contain drawn text (same size as original bitmap in this example).
bmp3 := TBitmap32.Create;
bmp3.Width := bmp2.Width;
bmp3.Height := bmp2.Height;
//Copy `bmp2` to `bmp3`.
bmp2.DrawMode := dmOpaque;
bmp2.DrawTo(bmp3, 0, 0);
//Mark all pixels as opaque (alpha = $FF)
MakeOpaque(bmp3);
//Draw text on `bmp3`. This will create proper aliasing.
bmp3.Font.Size := -16;
bmp3.Font.Color := clBlack;
bmp3.TextOut(2, 50, 'Red');
//Make all fully transparent pixels (TextOut) opaque and all fully opaque pixels
// (background coming from `bmp2`) transparent.
FlipTransparency(bmp3);
SaveBitmap32ToPNG(bmp3, 'c:\0\bmp3a.png');
//Blend `bmp3` on semi-transparent background (`bmp2`).
bmp3.DrawMode := dmBlend;
bmp3.DrawTo(bmp2, 0, 0);
SaveBitmap32ToPNG(bmp2, 'c:\0\bmp2a.png');
//Blend background + text onto main image.
bmp2.DrawMode := dmBlend;
bmp2.DrawTo(bmp1, 20, 20);
SaveBitmap32ToPNG(bmp1, 'c:\0\bmpcombineda.png');
bmp1.Free;
bmp2.Free;
bmp3.Free;
end;
Resulting images:
bmp1a:
bmp2a:
bmp3a:
bmpcombineda:

Graphics32 - saving transparent drawing layer to png

I draw a dotted line on a layer of an ImgView32. Later, I want to save each layer as transparent PNGs.
For any other layer that I have, the saving works just fine. But for the drawing layer, it does not.
In order to make the question simpler to understand, take the example code from the gr32 library, more specifically the Layers example. One of the options in its main menu is to add a custom drawing layer (New Custom Layer -> Simple Drawing Layer).
Then try to save that layer as a transparent PNG image and you will end up with a corrupted PNG file (you can't open it with any other picture viewer like for example Paint.net or Microsoft Photo Viewer). Same thing happens if you try to save the layer's bitmap32 as a bitmap as you can see in the bellow code...
I tried two approaches for saving Bitmap32 as a transparent PNG, so the first one is as follows:
procedure TMainForm.SavePNGTransparentX(bm32:TBitmap32; dest:string);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
try
Png.Assign(bm32);
Png.SaveToFile(dest);
finally
Png.Free;
end;
end;
So the above method works if I have a PNG loaded into the layer like this:
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromStream(myStream);
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
...
But as soon as I try to save the layer created with the code from the Layers example, the result is corrupted.
Even if I try to save the layer as bitmap like this (though this is not my intention since I need them to be PNG):
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
the same corruption occurs.
So, it's not like I receive an exception or anything... it just gets saved corrupted somehow;
I also tried other ways to save the Bitmap32 as transparent PNG, like for instance the GR32_PNG approach:
function SaveBitmap32ToPNG (sourceBitmap: TBitmap32;transparent: Boolean;bgColor32: TColor32;filename: String;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): boolean;
var png: TPNGImage;
begin
result := false;
try
png := Bitmap32ToPNG (sourceBitmap,false,transparent,WinColor(bgColor32),compressionLevel,interlaceMethod);
try
png.SaveToFile (filename);
result := true;
finally
png.Free;
end;
except
result := false;
end;
end;
where
function Bitmap32ToPNG (sourceBitmap: TBitmap32;paletted, transparent: Boolean;bgColor: TColor;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): TPNGImage; // TPNGObject
var
bm: TBitmap;
png: TPNGImage;//TPngObject;
TRNS: TCHUNKtRNS;
p: pngImage.PByteArray;
x, y: Integer;
begin
Result := nil;
png := TPngImage.Create; // TPNGObject
try
bm := TBitmap.Create;
try
bm.Assign (sourceBitmap); // convert data into bitmap
// force paletted on TBitmap, transparent for the web must be 8bit
if paletted then
bm.PixelFormat := pf8bit;
png.interlaceMethod := interlaceMethod;
png.compressionLevel := compressionLevel;
png.Assign(bm); // convert bitmap into PNG
// this is where the access violation occurs
finally
FreeAndNil(bm);
end;
if transparent then begin
if png.Header.ColorType in [COLOR_PALETTE] then begin
if (png.Chunks.ItemFromClass(TChunktRNS) = nil) then png.CreateAlpha;
TRNS := png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
if Assigned(TRNS) then TRNS.TransparentColor := bgColor;
end;
if png.Header.ColorType in [COLOR_RGB, COLOR_GRAYSCALE] then png.CreateAlpha;
if png.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA] then
begin
for y := 0 to png.Header.Height - 1 do begin
p := png.AlphaScanline[y];
for x := 0 to png.Header.Width - 1
do p[x] := AlphaComponent(sourceBitmap.Pixel[x,y]); // TARGB(bm.Pixel[x,y]).a;
end;
end;
end;
Result := png;
except
png.Free;
end;
end;
but using this approach, I get an EAccessViolation when trying to save this particular layer. For any other layers (not drawing ones), it does not crash my project except for this custom drawing one.
The access violation occurs at this line:
png.Assign(bm);
inside the Bitmap32ToPNG function
Do you have any idea why that happens and how can I prevent this?
EDIT
I tried using TBitmapLayer instead, because the TPositionedLayer might lack the Bitmap32 for some reason.
So my code is like this:
// adding a BitmapLayer and setting it's onPaint event to my handler
procedure TMainForm.Mynewlayer1Click(Sender: TObject);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,200);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnPaint := PaintMy3Handler;
except
Free;
raise;
end;
Selection := B;
end;
// and the PaintHandler is as follows:
procedure TMainForm.PaintMy3Handler(Sender: TObject;Buffer: TBitmap32);
var
Cx, Cy: Single;
W2, H2: Single;
const
CScale = 1 / 200;
begin
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
// Five black pixels, five white pixels since width of the line is 5px
Buffer.SetStipple([clBlack32, clBlack32, clBlack32, clBlack32, clBlack32,
clWhite32, clWhite32, clWhite32, clWhite32, clWhite32]);
W2 := (Right - Left) * 0.5;
H2 := (Bottom - Top) * 0.5;
Cx := Left + W2;
Cy := Top + H2;
W2 := W2 * CScale;
H2 := H2 * CScale;
Buffer.PenColor := clRed32;
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-2,Top);
Buffer.LineToFSP(Cx-2 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-1,Top);
Buffer.LineToFSP(Cx-1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx,Top);
Buffer.LineToFSP(Cx , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+1,Top);
Buffer.LineToFSP(Cx+1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+2,Top);
Buffer.LineToFSP(Cx+2 , Bottom);
end;
end;
Keep in mind that I use the default layers demo application. So this is just added code. I did not remove nor change anything in the demo code.
So I create a new layer (TBitmapLayer) and onPaint I do my drawing. In the end I want to save the contents of that layer as PNG. But it seems like the onPaint might draw somewhere else instead of the actual layer. Otherwise I do not understand why the saved image is empty.
So this time the resulted PNG is not corrupted, but it is empty...
The error is in the fact that the examples create TPositionedLayer layers which do not hold a bitmap. You can not type cast this layer type into a TBitmapLayer and expect it to create a bitmap image of the layer, as you do in this code:
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
I assume you do something similar to save to .png file, although you did not show that code.
The examples (with TPositionedLayer layers) use ImgView.Buffer for drawing on the screen. You can save that to a .png file like this:
SavePNGTransparentX(ImgView.Buffer, 'c:\tmp\imgs\buffer.png');
but I don't expect that to work satisfactorily for your separate layer images.
What is the reason you don't use TBitmapLayers as you have done before?
Edit after comments by user1137313
Inspired by the solution you found yourself (ref. your comment) I suggest the following which paints the layer to the extra bitmap only when needed for saving.
Starting from a menu item
procedure TMainForm.mnFileSaveClick(Sender: TObject);
begin
SaveLayerToPng(ImgView.Layers[ImgView.Layers.Count-1], 'c:\tmp\imgs\buffer.png');
end;
You possibly want to call SaveLayerToPng() in a loop if you save several layers at the same time, and also change the file name(s) as needed.
Then the SaveLayerToPng() procedure
procedure TMainForm.SaveLayerToPng(L: TCustomLayer; FileName: string);
var
bm32: TBitmap32;
begin
bm32:= TBitmap32.Create;
try
bm32.SetSizeFrom(ImgView.Buffer);
PaintSimpleDrawingHandler(L, bm32);
SavePNGTransparentX(bm32, FileName);
finally
bm32.Free;
end;
end;
It calls the existing PaintSimpleDrawingHandler(Sender: TObject; buffer: TBitmap32) procedure to paint to bm32 which it then passes on to `SavePNGTransparentX() for actual saving.
I used the paint handler of the Graphics32 example, but your PaintMy3Handler() can be used just as well.
The end result is same as your solution, just that the extra TBitmap32 is only painted when the file is to be saved.

How to draw a translucent image on a form?

I want to a draw a translucent image on a Delphi form, but for some reason it is not working.
Here is the original PNG (border is semi transparent):
I load the image in a TImage object:
Image1.Transparent := True;
Form1.Color := clWhite;
Form1.TransparentColor := True;
Form1.TransparentColorValue := clWhite;
The application:
The image isn't translucent. I am working with a BMP image that contains the alpha channel. Am I missing something?
I found a solution that will let you draw a BMP image with an alpha channel onto a form using only the Windows API:
const
AC_SRC_OVER = 0;
AC_SRC_ALPHA = 1;
type
BLENDFUNCTION = packed record
BlendOp,
BlendFlags,
SourceConstantAlpha,
AlphaFormat: byte;
end;
function WinAlphaBlend(hdcDest: HDC; xoriginDest, yoriginDest, wDest, hDest: integer;
hdcSrc: HDC; xoriginSrc, yoriginSrc, wSrc, hSrc: integer; ftn: BLENDFUNCTION): LongBool;
stdcall; external 'Msimg32.dll' name 'AlphaBlend';
procedure TForm4.FormClick(Sender: TObject);
var
hbm: HBITMAP;
bm: BITMAP;
bf: BLENDFUNCTION;
dc: HDC;
begin
hbm := LoadImage(0,
'C:\Users\Andreas Rejbrand\Skrivbord\RatingCtrl.bmp',
IMAGE_BITMAP,
0,
0,
LR_LOADFROMFILE);
if hbm = 0 then
RaiseLastOSError;
try
if GetObject(hbm, sizeof(bm), #bm) = 0 then RaiseLastOSError;
dc := CreateCompatibleDC(0);
if dc = 0 then RaiseLastOSError;
try
if SelectObject(dc, hbm) = 0 then RaiseLastOSError;
bf.BlendOp := AC_SRC_OVER;
bf.BlendFlags := 0;
bf.SourceConstantAlpha := 255;
bf.AlphaFormat := AC_SRC_ALPHA;
if not WinAlphaBlend(Canvas.Handle,
10,
10,
bm.bmWidth,
bm.bmHeight,
dc,
0,
0,
bm.bmWidth,
bm.bmHeight,
bf) then RaiseLastOSError;
finally
DeleteDC(dc);
end;
finally
DeleteObject(hbm);
end;
end;
Using The GIMP, I converted the PNG image
found here to a 32-bit RGBA bitmap, found here, and the result is very good:
Why not try do draw your png onto new image with regular bmp. Draw what you want onto image 2 and redraw /or assign/ all to your image 1 when finish. Must works...
The TransparentColorValue approach cannot possibly work, because this only works with images in which a single colour represents full transparency. [In addition, you are toying with the form's transparent colour instead of image's transparent colour!] The above PNG image is supposed to have an alpha channel, so it's not like every pixel is either shown or transparent -- instead, each pixel has an opacity between 0 and 1 (0.37, for instance). That is, in addition to the R, G, and B components of each pixel, there is an 'alpha' component A.
The above image appears to be corrupt, however. A 'correct' PNG is shown below:
(source: rejbrand.se)
You can try to blend the above one onto different backgrounds, and you will find that the shadow blends nicely.
So, if one has a 'correct' PNG, how to draw it onto a form? Well, that is going to be very difficult in your case, since Delphi 7 does not support PNG images. It only supports BMP images, and these normally do not have alpha channels.

Resources