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;
Related
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;
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;
I am writing a program using Delphi XE2. I draw some lines and shapes on a Canvas. I want to save that Canvas as an image file using a save dialog.
So I have a save button on my form and by clicking it, it opens the save dialog. How should I proceed to be able to save the Canvas?
At the moment you most likely have code in an OnPaint event for a TPaintBox or the form itself. That code might look like this:
procedure TMyForm.PaintBox1Paint(Sender: TObject);
begin
with PaintBox1.Canvas do
begin
MoveTo(0, 0);
LineTo(42, 666);
// and so on.
end;
end;
We need to do a little re-factoring. We need to extract that paint code into a separate method. Pass that method a canvas so that it is agnostic of the canvas on which it draws.
procedure TMyForm.PaintToCanvas(Canvas: TCanvas);
begin
with Canvas do
begin
MoveTo(0, 0);
LineTo(42, 666);
// and so on.
end;
end;
procedure TMyForm.PaintBox1Paint(Sender: TObject);
begin
PaintToCanvas(PaintBox1.Canvas);
end;
We are now back exactly where we started, but ready to strike at the real goal. Let's write a function to paint to a bitmap and then save to a file:
procedure TMyForm.PaintToFile(const FileName: string);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.SetSize(Paintbox1.Width, Paintbox1.Height);
PaintToCanvas(Bitmap.Canvas);
Bitmap.SaveToFile(FileName);
finally
Bitmap.Free;
end;
end;
This can naturally be extended to other image types like GIF, PNG, JPEG etc.
I've done it like this (using VCL). You'll have to set up the SaveDialog properly (make the user select valid image file types etc) but you should be able to that on your own. You can obviously replace the TPngImage with TJpegImge / directly save it as BMP or whatnot, maybe you want to allow multiple image extensions and use the appropriate one based on the user input from the SaveDialog.
procedure TForm2.Button1Click(Sender: TObject);
var Bmp: TBitmap;
Png: TPngImage;
begin
if SaveDialog1.Execute then
begin
Bmp := TBitmap.Create;
try
Bmp.SetSize(Canvas.ClipRect.Right, Canvas.ClipRect.Bottom);
BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);
Png := TPngImage.Create;
try
Png.Assign(Bmp);
Png.SaveToFile(SaveDialog1.FileName + '.png');
finally
Png.Free;
end;
finally
Bmp.Free;
end;
end;
end;
DNR: Generalizing a little your code, we have
uses Vcl.Imaging.pngimage
procedure TfrmPrincipalTest.PrintCanvas(aCanvas: TCanvas; aRect: TRect);
var Bmp: TBitmap;
Png: TPngImage;
begin
if sSaveDialog1.Execute then
begin
Bmp := TBitmap.Create;
try
Bmp.SetSize(aCanvas.ClipRect.Right, aCanvas.ClipRect.Bottom);
BitBlt(Bmp.Canvas.Handle, aRect.Top, aRect.Left, aRect.Right, aRect.Bottom, aCanvas.Handle, 0, 0, SRCCOPY);
Png := TPngImage.Create;
try
Png.Assign(Bmp);
Png.SaveToFile(sSaveDialog1.FileName + '.png');
finally
Png.Free;
end;
finally
Bmp.Free;
end;
end;
end;
procedure TfrmPrincipalTest.I1Click(Sender: TObject);
var vRect: TRect;
begin
vRect.Top:=0;
vRect.Left:=0;
vRect.Right:=sPageControl1.Width;
vRect.Bottom:=sPageControl1.Height;
PrintCanvas(sPageControl1.Canvas, vRect);
end;
The demo below tries to draw the GIF on form's canvas. It doesn't work. The image won't advance. How to make it work?
procedure TForm1.FormCreate(Sender: TObject);
begin
GIF := TGIFImage.Create;
GIF.LoadFromFile('c:\2.gif');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
GIF.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
VAR i: Integer;
begin
REPEAT
for i:= 0 to GIF.Images.Count-1 DO
begin
DisplayGifFrame(i);
Sleep(30);
end;
UNTIL FALSE;
end;
procedure TForm1.DisplayGifFrame(AIndex: Integer);
VAR
Renderer: TGIFRenderer;
begin
Renderer := TGIFRenderer.Create(GIF);
TRY
Renderer.Animate := TRUE;
Renderer.FrameIndex := AIndex;
Renderer.Draw(Canvas, Canvas.ClipRect);
{save frame in a bitmap here. save bitmap to disk}
// xxx
FINALLY
Renderer.Free;
end;
end;
What I want to achieve:
I want to extract all frames from a GIF and put each frame IN A UNIQUE bitmap.
Update:
Continued here: Cannot draw GIF on dynamically created TBitmap(s)
Try this:
procedure TForm1.Button1Click(Sender: TObject);
var
GIF: TGIFImage;
Bitmap: TBitmap;
I: Integer;
GR: TGIFRenderer;
R: TRect;
begin
GIF := TGIFImage.Create;
Bitmap := TBitmap.Create;
try
GIF.LoadFromFile('c:\test\test.gif');
Bitmap.SetSize(GIF.Width, GIF.Height);
GR := TGIFRenderer.Create(GIF);
try
for I := 0 to GIF.Images.Count - 1 do
begin
if GIF.Images[I].Empty then Break;
GR.Draw(Bitmap.Canvas, Bitmap.Canvas.ClipRect);
GR.NextFrame;
Bitmap.SaveToFile(Format('%.2d.bmp', [I]));
end;
finally
GR.Free;
end;
finally
GIF.Free;
Bitmap.Free;
end;
end;
The above code takes into account Frame's Disposal method. see related question here.
I am using TGifImage that is included with Delphi XE.
What I am trying to do is load a Gif from a File and and extract all the frames to a Bitmap.
This is what I did so far:
procedure ExtractGifFrames(FileName: string);
var
Gif: TGifImage;
Bmp: TBitmap;
i: Integer;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile(FileName);
Bmp := TBitmap.Create;
try
Bmp.SetSize(Gif.Width, Gif.Height);
for i := 0 to Gif.Images.Count - 1 do
begin
if not Gif.Images[i].Empty then
begin
Bmp.Assign(Gif.Images[i]);
Bmp.SaveToFile('C:\test\bitmap' + IntToStr(i) + '.bmp');
end;
end;
finally
Bmp.Free;
end;
finally
Gif.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
begin
ExtractGifFrames(OpenPictureDialog1.FileName);
end;
end;
The problem I am facing is with some transparency issue with a lot of different Gifs, and also size problems.
Here are some example bitmaps that were saved using my code above:
As you can see the results are not great, they have size and transparency issues.
I know the Gif Files themselves are not corrupt, because I can load them through my web browser and they display correctly without fault.
How can I load a Gif from File, assign each frame to Bitmap without losing any quality?
For older Delphi Versions (Pre 2009): Take a look at the code of GIFImage unit, you might want to check how TGIFPainter renders the images based on each Frame's Disposal method.
I have wrote a small code utilizing TGIFPainter.OnAfterPaint event handler to save the active frame to BMP, and do all the "hard work".
Note: GIFImage unit version 2.2 Release: 5 (23-MAY-1999)
type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
public
FBitmap: TBitmap;
procedure AfterPaintGIF(Sender: TObject);
end;
...
procedure TForm1.Button1Click(Sender: TObject);
var
GIF: TGIFImage;
begin
GIF := TGIFImage.Create;
FBitmap := TBitmap.Create;
Button1.Enabled := False;
try
GIF.LoadFromFile('c:\test\test.gif');
GIF.DrawOptions := GIF.DrawOptions - [goLoop, goLoopContinously, goAsync];
GIF.AnimationSpeed := 1000; // Max - no delay
FBitmap.Width := GIF.Width;
FBitmap.Height := GIF.Height;
GIF.OnAfterPaint := AfterPaintGIF;
ProgressBar1.Max := Gif.Images.Count;
ProgressBar1.Position := 0;
ProgressBar1.Smooth := True;
ProgressBar1.Step := 1;
// Paint the GIF onto FBitmap, Let TGIFPainter do the painting logic
// AfterPaintGIF will fire for each Frame
GIF.Paint(FBitmap.Canvas, FBitmap.Canvas.ClipRect, GIF.DrawOptions);
ShowMessage('Done!');
finally
FBitmap.Free;
GIF.Free;
Button1.Enabled := True;
end;
end;
procedure TForm1.AfterPaintGIF(Sender: TObject);
begin
if not (Sender is TGIFPainter) then Exit;
if not Assigned(FBitmap) then Exit;
// The event will ignore Empty frames
FBitmap.Canvas.Lock;
try
FBitmap.SaveToFile(Format('%.2d.bmp', [TGIFPainter(Sender).ActiveImage]));
finally
FBitmap.Canvas.Unlock;
end;
ProgressBar1.StepIt;
end;
Note: No error handling to simplify the code.
For newer Delphi Versions (2009+): With build-in GIFImg unit, you can do this quit easy with the use of TGIFRenderer (which completely replaced old TGIFPainter) e.g.:
procedure TForm1.Button1Click(Sender: TObject);
var
GIF: TGIFImage;
Bitmap: TBitmap;
I: Integer;
GR: TGIFRenderer;
begin
GIF := TGIFImage.Create;
Bitmap := TBitmap.Create;
try
GIF.LoadFromFile('c:\test\test.gif');
Bitmap.SetSize(GIF.Width, GIF.Height);
GR := TGIFRenderer.Create(GIF);
try
for I := 0 to GIF.Images.Count - 1 do
begin
if GIF.Images[I].Empty then Break;
GR.Draw(Bitmap.Canvas, Bitmap.Canvas.ClipRect);
GR.NextFrame;
Bitmap.SaveToFile(Format('%.2d.bmp', [I]));
end;
finally
GR.Free;
end;
finally
GIF.Free;
Bitmap.Free;
end;
end;
Using GDI+:
uses ..., GDIPAPI, GDIPOBJ, GDIPUTIL;
procedure ExtractGifFrames(const FileName: string);
var
GPImage: TGPImage;
encoderClsid: TGUID;
BmpFrame: TBitmap;
MemStream: TMemoryStream;
FrameCount, FrameIndex: Integer;
begin
GPImage := TGPImage.Create(FileName);
try
if GPImage.GetLastStatus = Ok then
begin
GetEncoderClsid('image/bmp', encoderClsid);
FrameCount := GPImage.GetFrameCount(GDIPAPI.FrameDimensionTime);
for FrameIndex := 0 to FrameCount - 1 do
begin
GPImage.SelectActiveFrame(GDIPAPI.FrameDimensionTime, FrameIndex);
MemStream := TMemoryStream.Create;
try
if GPImage.Save(TStreamAdapter.Create(MemStream), encoderClsid) = Ok then
begin
MemStream.Position := 0;
BmpFrame := TBitmap.Create;
try
BmpFrame.LoadFromStream(MemStream);
BmpFrame.SaveToFile(Format('%.2d.bmp', [FrameIndex]));
finally
BmpFrame.Free;
end;
end;
finally
MemStream.Free;
end;
end;
end;
finally
GPImage.Free;
end;
end;
The frames of an animated GIF file often only contain the differences from the previous frame (an optimisation technique to reduce file size). So in order to produce a snapshot of the GIF at a particular point, you'll have to paste all the frames up to that point, one after the other.
We can achieve this by using Draw() with its 'draw transparently' option set:
procedure ExtractGifFrames(FileName: string);
var
Gif: TGifImage;
Bmp: TBitmap;
i: Integer;
Bounds: TRect;
begin
Gif := TGifImage.Create;
try
Gif.LoadFromFile(FileName);
Bounds := Rect(0, 0, Gif.Width-1, Gif.Height-1);
Bmp := TBitmap.Create;
try
Bmp.SetSize(Gif.Width, Gif.Height);
Bmp.PixelFormat := pf32bit;
for i := 0 to Gif.Images.Count - 1 do
begin
if not Gif.Images[i].Empty then
begin
Gif.Images[i].Draw(Bmp.Canvas, Bounds, True, True);
Bmp.SaveToFile(IntToStr(i) + '.bmp');
end;
end;
finally
Bmp.Free;
end;
finally
Gif.Free;
end;
end;
NB: There are other elements to the animated GIF format, which specify the amount of times frames are to be repeated etc. but they may not concern you.