I am using this function to draw a png over a TImage on a specific location:
procedure TForm1.PlacePNG(nam: string; px, py: Integer);
var
vPic: TPicture;
vSrc: TGraphic;
begin
vPic := TPicture.Create;
try
vPic.LoadFromFile(Nam);
vSrc := vPic.Graphic;
Image1.Canvas.Draw(px, py, vSrc);
finally
vPic.Free;
end;
end;
My question: what is the best way to do this with part of the png file, without losing its transparency?
This is an interesting question!
Of course, drawing the entire PNG is trivial:
procedure TForm1.FormCreate(Sender: TObject);
var
bg, fg: TPngImage;
begin
bg := TPngImage.Create;
try
bg.LoadFromFile('K:\bg.png');
fg := TPngImage.Create;
try
fg.LoadFromFile('K:\fg.png');
Image1.Picture.Graphic := bg;
Image2.Picture.Graphic := fg;
fg.Draw(bg.Canvas, Rect(0, 0, fg.Width, fg.Height));
Image3.Picture.Graphic := bg;
finally
fg.Free;
end;
finally
bg.Free;
end;
end;
To draw only a part, one possible solution is to obtain the images as 32-bpp RGBA bitmaps and then use the Windows API, specifically, the AlphaBlend function:
procedure TForm1.FormCreate(Sender: TObject);
var
bg, fg: TPngImage;
bgbm, fgbm: TBitmap;
BlendFunction: TBlendFunction;
begin
// Load background PNG
bg := TPngImage.Create;
try
bg.LoadFromFile('K:\bg.png');
// Load foreground PNG
fg := TPngImage.Create;
try
fg.LoadFromFile('K:\fg.png');
// Preview background and foreground
Image1.Picture.Graphic := bg;
Image2.Picture.Graphic := fg;
// Create background BMP
bgbm := TBitmap.Create;
try
bgbm.Assign(bg);
// Create foreground BMP
fgbm := TBitmap.Create;
try
fgbm.Assign(fg);
// Blend PART OF foreground BMP onto background BMP
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
if not Winapi.Windows.AlphaBlend(
bgbm.Canvas.Handle,
100,
100,
200,
200,
fgbm.Canvas.Handle,
200,
200,
200,
200,
BlendFunction
) then
RaiseLastOSError;
// Preview result
Image3.Picture.Graphic := bgbm;
finally
fgbm.Free;
end;
finally
bgbm.Free;
end;
finally
fg.Free;
end;
finally
bg.Free;
end;
end;
Related
Problem Definition
I am trying to create a custom bitmap brush with transparency but it doesn't seem to be working as expected. If you look at this example. Add the code and hook up the paint, create and destroy events.
type
TForm3 = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FBitmap: TBitmap;
end;
// Implementation
function CreateBlockBitmap(const APenColor: TColor): TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsClear;
Result.PixelFormat := pf32bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := APenColor;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap(clRed);
end;
procedure TForm3.FormPaint(Sender: TObject);
var
colNum: Integer;
rowNum: Integer;
begin
// Paint the rectangle using the brush
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
Canvas.Rectangle(50, 50, 250, 250);
// Draw the block using Canvas.Draw
for rowNum := 0 to 9 do
for colNum := 0 to 9 do
Canvas.Draw(350 + rowNum * 20, 50 + colNum * 20, FBitmap);
end;
This code produces two painted blocks. The left one is painted using a bitmap brush and the right hand side one is painted using a number of Canvas.Draw calls.
I need the brush to be painted with transparency similar to what would happen if you used a hatch brush. This SO answer seems to indicate that it's possible:
How can I draw a patternBrush with transparent backround (GDI)?
What I have tried
1) I tried using a solid background color instead of using bsClear. This just makes the background white.
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
If I use clFuchsia then the color is Fuchsia. I also tried painting the background clFuchsia and then setting the TransparentColor to clFuchsia. The Canvas.Draw option paints with transparency and the brush doesn't.
2) I tried setting the alpha channel directly with the following code:
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;
And then calling this routine immediately after the rectangle has been painted using the background color.
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
SetAlphaBitmap(Result, clBlack, 0); // Set the alpha channel
end;
I know that the alpha channel is working because if I pass in an alpha value of 255 then it shows up in black in the Canvas.Draw too.
SetAlphaBitmap(Result, clBlack, 255);
3) I tried testing by creating a pattern brush and assigning that instead of the bitmap. That produces exactly the same results. FBrush is an HBRUSH.
FBrush := CreatePatternBrush(FBitmap.Handle);
And the setting the brush like this:
Canvas.Brush.Handle := FBrush;
4) I tried calling SetBkMode as indicated in the SO answer above. That made no difference at all.
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap;
SetBkMode(Canvas.Handle, TRANSPARENT); // This doesn't make a difference
Canvas.Rectangle(50, 50, 250, 250);
Edit
5) I just tested with a Monochrome bitmap and it has the same problem. The image is painted with a white background and black foreground for the brush and transparent for the Canvas.Draw.
function CreateMonochromeBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
Result.PixelFormat := pf1bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
And in the constructor:
FBitmap := CreateMonochromeBitmap;
FBrush := CreatePatternBrush(FBitmap.Handle);
In the paint we set the handle rather than the bitmap property.
Canvas.Brush.Handle := FBrush;
Try to clear the canvas this null color before your drawing loop.
Canvas.Clear(TAlphaColorRec.Null);
Greetings.
Pau.
You need to use white color for transparent areas and SetROP2 before filling the rectangle, like this:
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(50, 50, 250, 250);
And don't forget to restore the previous ROP mode.
Good luck!
Solved! Here is my solution:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
public
FBitmap: TBitmap;
end;
//Implementation
function CreateBlockBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf1bit; //!! 1-bit
Result.Width := 20;
Result.Height := 20;
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.FillRect(Rect(0, 0, 10, 10));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
const
PatternColor = clRed; //brush color to be used
var
R: TRect;
begin
//filling the background with different colors for test
Canvas.Brush.Color := clGreen;
Canvas.FillRect(Rect(0,0,100,600));
Canvas.Brush.Color := clAqua;
Canvas.FillRect(Rect(100,0,200,600));
Canvas.Brush.Color := clYellow;
Canvas.FillRect(Rect(200,0,300,600));
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Rect(300,0,400,600));
//draw the rectangle
R := Rect(50, 50, 500, 500);
Canvas.Brush.Color := PatternColor;
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
Canvas.Brush.Bitmap := FBitmap;
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(R); //draw any figure here
Canvas.Brush.Color := PatternColor;
SetROP2(Canvas.Handle, R2_COPYPEN);
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
end;
I am trying to convert a gif to png, that's easy, but the problem is the result image is not transparent, also I would like to have in the png image the alpha channel.
This is my code:
procedure TForm1.Button1Click(Sender: TObject);
var
png: TPngImage;
p : TPicture;
begin
p := TPicture.Create;
p.LoadFromFile('C:\temp\php.gif');
png := TPngImage.CreateBlank(COLOR_RGB , 8, p.Width, p.Height);
png.Canvas.Draw(0,0, p.Graphic);
png.SaveToFile('C:\Windows\Temp\test.png');
end;
The new picture has the background black, should be transparent.
If I try to add the ALPHA in the constructor, is 100% transparent.
png := TPngImage.CreateBlank(COLOR_RGBALPHA , 8, p.Width, p.Height);
Since Delphi XE 2 GDI+ is supported, which offers real easy to use options for conversions.
You just need to create TGPImage providing the image file to load and save this image with the wished encoder, found by the desired mime type.
uses Winapi.GDIPAPI, Winapi.GDIPOBJ, Winapi.GDIPUTIL;
procedure TForm8.Button1Click(Sender: TObject);
var
encoderClsid: TGUID;
stat: TStatus;
IMG: TGPImage;
begin
IMG := TGPImage.Create('C:\temp\transparent.gif');
try
GetEncoderClsid('image/png', encoderClsid);
stat := IMG.Save('C:\temp\transparent.png', encoderClsid, nil);
finally
IMG.Free;
end;
if (stat = Ok) then
Showmessage('Success');
end;
examples for the mime types:
image/bmp
image/jpeg
image/gif
image/tiff
image/png
Just by drawing GIF image on PNG canvas will not move transparency information from GIF image to PNG.
You will have to do it yourself.
ForceAlphaChannel procedure will create alpha channel for any PNG image based on given TransparentColor.
procedure ForceAlphaChannel(Image: TPngImage; BitTransparency: Boolean; TransparentColor: TColor; Amount: Byte);
var
Temp: TPngImage;
x, y: Integer;
Line: VCL.Imaging.PngImage.pByteArray;
PixColor: TColor;
begin
Temp := TPngImage.CreateBlank(COLOR_RGBALPHA, 8, Image.Width, Image.Height);
try
for y := 0 to Image.Height - 1 do
begin
Line := Temp.AlphaScanline[y];
for x := 0 to Image.Width - 1 do
begin
PixColor := Image.Pixels[x, y];
Temp.Pixels[x, y] := PixColor;
if BitTransparency and (PixColor = TransparentColor) then Line^[x] := 0
else Line^[x] := Amount;
end;
end;
Image.Assign(Temp);
finally
Temp.Free;
end;
end;
If you add call to ForceAlphaChannel after you have drawn GIF image you will get transparency based on transparent color you define.
procedure TForm1.Button1Click(Sender: TObject);
var
png: TPngImage;
p : TPicture;
TransparentColor: TColor;
begin
p := TPicture.Create;
p.LoadFromFile('C:\temp\php.gif');
TransparentColor := clFuchsia;
png := TPngImage.CreateBlank(COLOR_RGB , 8, p.Width, p.Height);
// set png background color to same color that will be used for setting transparency
png.Canvas.Brush.Color := TransparentColor;
png.Canvas.FillRect(rect(0, 0 , p.Width, p.Height));
png.Canvas.Draw(0, 0, p.Graphic);
ForceAlphaChannel(png, true, TransparentColor, 255);
png.SaveToFile('C:\Windows\Temp\test.png');
end;
For older/new Delphi versions (in newer version - change TPngObject to TPngImage).
If you need to save every frame of (animated) GIF into PNG (works for non-animated GIFS also):
The first variant code is compatible with the newer pngimage Version 1.56+ (which supports the CreateBlank constructor)
procedure TForm1.Button1Click(Sender: TObject);
var
Gif: TGifImage;
Png: TPngObject; // for new Delphi versions use "TPngImage"
Bmp: TBitmap;
TransparentColor, Pixel: TColor;
I, X, Y: Integer;
AlphaScanline: pByteArray;
IsTransparent: Boolean;
ColorType: Cardinal;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile('C:\Downloads\ajax-loader.gif');
for I := 0 to Gif.Images.Count - 1 do
begin
IsTransparent := Gif.Images[I].Transparent;
TransparentColor := Gif.Images[I].GraphicControlExtension.TransparentColor;
Bmp := Gif.Images[I].Bitmap;
if IsTransparent then
ColorType := COLOR_RGBALPHA
else
ColorType := COLOR_RGB;
Png := TPngObject.CreateBlank(ColorType, 8, Bmp.Width, Bmp.Height); // for new Delphi versions use "TPngImage"
try
AlphaScanline := nil;
for Y := 0 to Bmp.Height - 1 do
begin
if IsTransparent then
AlphaScanline := Png.AlphaScanline[Y];
for X := 0 to Bmp.Width - 1 do
begin
Pixel := Bmp.Canvas.Pixels[X, Y];
Png.Pixels[X, Y] := Pixel;
if IsTransparent then
begin
if (Pixel = TransparentColor) then
AlphaScanline^[X] := 0
else
AlphaScanline^[X] := 255;
end;
end;
end;
Png.SaveToFile(Format('%d.png', [I]));
finally
Png.Free;
end;
end;
finally
Gif.Free;
end;
end;
For old pngimage version before 1.56 which do not support TPngObject.CreateBlank:
procedure TForm1.Button2Click(Sender: TObject);
var
Gif: TGifImage;
Png: TPngObject; // for new Delphi versions use "TPngImage"
Bmp: TBitmap;
TransparentColor, Pixel: TColor;
I, X, Y: Integer;
AlphaScanline: pByteArray;
IsTransparent: Boolean;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile('C:\Downloads\ajax-loader.gif');
for I := 0 to Gif.Images.Count - 1 do
begin
IsTransparent := Gif.Images[I].Transparent;
Png := TPngObject.Create; // for new Delphi versions use "TPngImage"
try
if IsTransparent then
begin
Bmp := TBitmap.Create;
Bmp.Assign(Gif.Images[I].Bitmap);
Bmp.PixelFormat := pf24bit;
Png.Assign(Bmp);
Png.CreateAlpha;
TransparentColor := Gif.Images[I].GraphicControlExtension.TransparentColor;
for Y := 0 to Bmp.Height - 1 do
begin
AlphaScanline := Png.AlphaScanline[Y];
for X := 0 to Bmp.Width - 1 do
begin
Pixel := Png.Pixels[X, Y];
if (Pixel = TransparentColor) then
AlphaScanline^[X] := 0;
end;
end;
Bmp.Free;
end
else
Png.Assign(Gif.Images[I].Bitmap);
Png.SaveToFile(Format('%d.png', [I]));
finally
Png.Free;
end;
end;
finally
Gif.Free;
end;
end;
All methods blend with system highlight blue color.
ImageList1.BlendColor := clGray;
ImageList1.DrawingStyle := dsSelected;
ImageList1.GetIcon(0, icon);
ImageList1.GetIcon(0, icon, dsSelected, itImage);
icon.handle := ImageList_GetIcon(ImageList1.Handle, 0, ILD_SELECTED);
BlendColor property is used by the Draw method of the ImageList (or DrawOverlay).
ImageList1.Draw(Canvas, 0, 0, 0);
will use the color you specified in BlendColor when DrawingStyle is 'dsSelected' or 'dsFocus'.
The system, when you request it to do so, uses system colors, like 'highlight', 'selected'... Hence your call to the winapi function will result as such.
As there's no built-in way to request a blended icon from an ImageList, you can request it to do the blending for you over a bitmap and then convert it to an icon. You can find an example here, for instance, that uses a temporary image list, or here. Or, you can get the list to draw the image and its mask to combine them into an icon, maybe like the below:
var
Icon: TIcon;
Bmp: TBitmap;
MaskBmp: TBitmap;
IconInfo: TIconInfo;
begin
Icon := TIcon.Create;
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32bit;
Bmp.Canvas.Brush.Color := clBlack;
Bmp.Width := ImageList1.Width;
Bmp.Height := ImageList1.Height;
MaskBmp := TBitmap.Create;
try
MaskBmp.PixelFormat := pf32bit;
MaskBmp.Canvas.Brush.Color := clWhite;
MaskBmp.Width := ImageList1.Width;
MaskBmp.Height := ImageList1.Height;
ImageList1.BlendColor := clRed;
ImageList1.Draw(Bmp.Canvas, 0, 0, 0, dsSelected, itImage);
ImageList1.Draw(MaskBmp.Canvas, 0, 0, 0, dsNormal, itMask);
IconInfo.fIcon := True;
IconInfo.hbmMask := MaskBmp.Handle;
IconInfo.hbmColor := Bmp.Handle;
Icon.Handle := CreateIconIndirect(IconInfo);
finally
MaskBmp.Free;
end;
finally
Bmp.Free;
end;
end;
I have a TImgView32(named CityMap) on my form and an image is loaded on it. Now I create a layer(TBitmapLayer) and draw a circle using Canvas.Ellipse of a TBitmap32 variable like the following:
procedure TfrmMain.Button1Click(Sender: TObject);
var
tmpBmp: TBitmap32;
tmpBL: TBitmapLayer;
begin
tmpBL:= TBitmapLayer.Create(CityMap.Layers);
tmpBmp:= TBitmap32.Create;
with tmpBmp do
begin
//Clear;
SetSize(50, 50);
Canvas.Brush.Color := clYellow;
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Color := clBlue;
Canvas.Pen.Width := 2;
Canvas.Ellipse(Rect(0, 0, 50, 50));
end;
with tmpBL do
begin
Scaled:=true;
Bitmap.DrawMode:=dmBlend;
tmpBL.Bitmap:=(tmpBmp);
//tmpBmp.DrawTo(tmpBL.Bitmap, 0, 0); This line doesn't work! So using above line instead
end;
//...
end;
The result is like this:
As you see the problem is that annoying black rectangle. How to create a result like this:
Use dmTransparent draw mode for the DrawMode property of your TBitmap32 image:
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap32;
Layer: TBitmapLayer;
begin
Layer := TBitmapLayer.Create(CityMap.Layers);
Bitmap := TBitmap32.Create;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(50, 50);
Bitmap.Canvas.Brush.Color := clYellow;
Bitmap.Canvas.Brush.Style:= bsSolid;
Bitmap.Canvas.Pen.Color := clBlue;
Bitmap.Canvas.Pen.Width := 2;
Bitmap.Canvas.Ellipse(Rect(0, 0, 50, 50));
Layer.Scaled := True;
Layer.Bitmap := Bitmap;
...
end;
I want to crop and align the inserted BMP from the clipboard.
I'm trying for 2 days but still nothing workable...
procedure TForm1.act1Execute(Sender: TObject);
var
BMP : TBitmap;
begin
BMP := TBitmap.Create;
BMP.Assign(Clipboard);
BMP.SetSize(400,200);
Img1.picture.Graphic := BMP;
BMP.Free;
end;
procedure TForm1.act1Update(Sender: TObject);
begin
(Sender as TAction).Enabled := Clipboard.HasFormat(CF_BITMAP);
end;
end.
If I understand you right, you need to center the bitmap in the Image control?
It's simple - set the Img1.Center := True
To crop the bitmap you need code like this:
procedure CropBitmap(Bmp: TBitmap; const CropRect: TRect);
var
CropBmp: TBitmap;
begin
CropBmp := TBitmap.Create;
try
CropBmp.Width := CropRect.Right - CropRect.Left;
CropBmp.Height := CropRect.Bottom - CropRect.Top;
CropBmp.Canvas.CopyRect(
Rect(0, 0, CropBmp.Width, CropBmp.Height),
Bmp.Canvas,
CropRect
);
Bmp.Assign(CropBmp);
finally
CropBmp.Free;
end;
end;