How to extract frames from a TGifImage into Bitmaps? - delphi

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.

Related

TImage - dynamically load resource by component name

I will assign this procedure into OnMouseEnter. I have some TImage that will change it's picture OnMouseEnter. It is easier to make each procedure of it on event handler. But i don't like to repeat the same code.
var
i: Integer;
CoName: TComponent;
png: TPngImage;
s: string;
begin
s := '';
for i := 1 to 16 do
begin
CoName := Form1.Components[i];
if CoName is TImage then
begin
s := CoName.Name;
Break;
end;
end;
if Trim(s) <> '' then
begin
png := TPngImage.Create;
try
png.LoadFromResourceName(hInstance, 'ResImgA');
// s.picture.Assign(png); > i can not do this
finally
FreeAndNil(png);
end;
end;
end;
How can i allow s into TImage.Name ?
Set the OnMouseEnter event of all the TImage objects to point to the same event handler, and use its Sender parameter to identify which TImage is calling the handler:
procedure TForm38.ImageMouseEnter(Sender: TObject);
var
ResName: string;
im: TImage;
png: TPngImage;
begin
im := Sender as TImage;
// if your image resources are named as 'Res' + name of TImage (eg. 'ImgA')
// you can combine these as
ResName := 'Res' + im.Name;
png := TPngImage.Create;
try
png.LoadFromResourceName(hInstance, ResName);
im.picture.Assign(png);
finally
png.Free;
end;
end;
I do this and it's work fine, you don't need String variable or loops:
procedure TForm1.Image1MouseEnter(Sender: TObject);
Var PngImg : TPngImage;
// Image : TImage; < -- If you need to handle error
begin
//Image := Sender as TImage; and remove IF
if Sender is TImage then
begin
PngImg := TPngImage.Create;
try
PngImg.LoadFromResourceName(HInstance , 'PngImage_1');
TImage(Sender).Picture.Assign(PngImg);
finally
PngImg.Free;
end ;
end;
end;
For all the other Timage (15) , you can set the event without repeat the code from the object inspector as:

delphi bitmap position manipulation

I've this event to draw on a bitmap :
procedure TForm1.Button1Click(Sender: TObject);
var
SrcBmp,MyBitmap: TBitmap;
MyRect: TRectF;
begin
SrcBmp:=TBitmap.CreateFromFile('android.png');
try
MyBitmap := TBitmap.CreateFromFile('fav.png');
try
MyRect.Left :=0;
MyRect.Top := 0;
MyRect.Bottom := MyBitmap.Height;
MyRect.Right := MyBitmap.Width;
SrcBmp.Canvas.BeginScene() ;
SrcBmp.Canvas.DrawBitmap(MyBitmap,MyRect
,MyRect, 50);
SrcBmp.Canvas.EndScene;
finally
MyBitmap.Free;
end;
Image1.Bitmap.Assign(SrcBmp);
finally
SrcBmp.Free;
end;
end;
The Result is :
But what i want to get is this result :
I tried to decrease the MyRect.Left and MyRect.Top , but that didn't give the 2nd result .
PS: the fav.png dimensions is 16x16 .
Many thanks
As others have pointed out:
procedure TForm1.Button1Click(Sender: TObject);
var
SrcBmp,MyBitmap: TBitmap;
MyRect,
DestRect: TRectF;
begin
SrcBmp:=TBitmap.CreateFromFile('android.png');
try
MyBitmap := TBitmap.CreateFromFile('fav.png');
try
MyRect:=TRectF.Create(0,0,MyBitmap.Width, MyBitmap.Height);
DestRect:=TRectF.Create(ScrBmp.Width-MyBitmap.width, ScrBmp.Height-MyBitmap.Height, MyBitmap.Width, MyBtmap.Height);
SrcBmp.Canvas.BeginScene() ;
SrcBmp.Canvas.DrawBitmap(MyBitmap,MyRect, DestRect, 50);
SrcBmp.Canvas.EndScene;
DestRect.Free;
MyRect.Free;
finally
MyBitmap.Free;
end;
Image1.Bitmap.Assign(SrcBmp);
finally
SrcBmp.Free;
end;
end;

Problems with TVideoImage [duplicate]

I'm using Delphi7 and VFrames (TVideoImage) with this Procedure
uses VFrames;
....
procedure TForm1.snapshot;
var
cam:TVideoImage;
strlst:TStringList;
BMP:TBitmap;
begin
strlst := TStringList.Create ;
cam :=TVideoImage.Create;
cam.GetListOfDevices(strlst);
cam.VideoStart(strlst.Strings[0]); //specify a cam by number
//get snapshot
BMP := TBitmap.Create;
cam.GetBitmap(BMP);
BMP.SaveToFile('test.bmp');
cam.VideoStop;
BMP.Free;
end;
Result blank Bitmap file.
I made a small wrapper class for VFrames/VSample:
unit u_class_webcam;
interface
uses
Jpeg,
Forms,
VSample,
VFrames,
Classes,
Graphics,
SysUtils;
type
TWebcam = class
private
Video : TVideoImage;
Devices : TStringList;
Resolutions : TStringList;
function GetDeviceReady: Boolean;
function GetHeight: Integer;
function GetWidth: Integer;
function GetActiveDevice: String;
public
constructor Create;
destructor Destroy; override;
procedure SetDisplayCanvas(const Canvas : TCanvas);
procedure TakeSnapshot(const Filename : String);
function TakeSnapshotToBmp : TBitmap;
procedure Start;
procedure Stop;
property DeviceReady : Boolean read GetDeviceReady;
property Width : Integer read GetWidth;
property Height : Integer read GetHeight;
property ActiveDevice : String read GetActiveDevice;
end;
// webcam singleton
var
Webcam : TWebcam;
implementation
{ TWebcam }
function TWebcam.GetActiveDevice: String;
begin
Result := '';
if Devices.Count > 0 then
Result := Devices[0];
end;
function TWebcam.GetHeight: Integer;
begin
Result := Video.VideoHeight;
end;
function TWebcam.GetWidth: Integer;
begin
Result := Video.VideoWidth;
end;
function TWebcam.GetDeviceReady: Boolean;
begin
Video.GetListOfDevices(Devices);
Result := Devices.Count > 0;
end;
procedure TWebcam.SetDisplayCanvas(const Canvas : TCanvas);
begin
Video.SetDisplayCanvas(Canvas);
end;
function TWebcam.TakeSnapshotToBmp : TBitmap;
begin
Result := TBitmap.Create;
Bitmap.PixelFormat := pf24bit;
Video.GetBitmap(Result);
end;
procedure TWebcam.TakeSnapshot(const Filename: String);
var
Bitmap : TBitmap;
Jpeg : TJpegImage;
begin
Bitmap := TBitmap.Create;
JPeg := TJpegImage.Create;
try
Bitmap.PixelFormat := pf24bit;
Video.GetBitmap(Bitmap);
JPeg.Assign(Bitmap);
JPeg.SaveToFile(Filename);
finally
Bitmap.Free;
JPeg.Free;
end;
end;
procedure TWebcam.Start;
begin
if DeviceReady then
begin
Video.VideoStart(Devices[0]);
Video.GetListOfSupportedVideoSizes(Resolutions);
Video.SetResolutionByIndex(Resolutions.Count-1);
end;
end;
procedure TWebcam.Stop;
begin
if Video.VideoRunning then
Video.VideoStop;
end;
constructor TWebcam.Create;
begin
Devices := TStringList.Create;
Resolutions := TStringList.Create;
Video := TVideoImage.Create;
end;
destructor TWebcam.Destroy;
begin
Stop;
Devices.Free;
Resolutions.Free;
Application.ProcessMessages;
Video.Free;
end;
end.
usage:
procedure TForm1.TestIt;
var Bmp : TBitmap;
begin
WebCam := TWebCam.Create;
try
WebCam.Start;
WebCam.SetDisplayCanvas(Self.Canvas);
Bmp := WebCam.TakeSnapShotToBmp;
// do something with BMP
Bmp.Free;
WebCam.Stop;
finally
WebCam.Free;
end;
end;
Since the GetBitmap Function of TVideoImage may deliver empty images if directly called after the call to VideoStart, it might be necessary to Create TVideoImage add an OnNewVideoFrame event to get the information that an image is available. So the steps would be:
Create and start
wait for an image an take it
Free
Since the question was asking for a single shot solution and threading or idle looping after VideoStart do not work, I'd provide a solutions which would encapsulate the mentioned steps.
The call would be:
procedure TMyForm.FormCreate(Sender: TObject);
begin
ReportMemoryLeaksOnShutDown := true;
end;
procedure TMyForm.ImgCallBack(BMP:TBitMap);
begin
Image1.Picture.Assign(BMP);
end;
procedure TMyForm.Button3Click(Sender: TObject);
begin
With TGrabClass.Create do GetImage(ImgCallBack);
end;
with the base implementation of TGrabClass of:
unit u_GrabOnlyBitMap;
interface
uses
Classes,
Messages,
Windows,
Graphics,
VSample,
VFrames;
type
TImageCallBack=Procedure(bmp:TBitMap) of Object;
TGrabClass=Class
FReady:Boolean;
FVideo:TVideoImage;
FBitMap:TBitMap;
Handle:THandle;
FImageCallBack:TImageCallBack;
Procedure GetImage(cb:TImageCallBack);
Constructor Create;
Destructor Destroy;Override;
private
procedure NewVideoFrameEvent(Sender: TObject; Width, Height: integer;
DataPtr: pointer);
procedure WndMethod(var Msg: TMessage);
procedure Suicide;
End;
implementation
const
WM_MyKill=WM_user + 666;
// Called by asnc PostMessage with WM_MyKill to free
Procedure TGrabClass.WndMethod(var Msg: TMessage);
begin
if Msg.Msg = WM_MyKill then
begin
Msg.Result := -1;
Free;
end
else
Msg.Result := DefWindowProc(Handle, Msg.Msg, Msg.wParam, Msg.lParam);
end;
constructor TGrabClass.Create;
var
sl:TStringList;
begin
inherited;
Handle := AllocateHWnd(WndMethod);
sl:=TStringList.Create;
FVideo:=TVideoImage.Create;
FBitMap := TBitmap.Create;
FVideo.OnNewVideoFrame := NewVideoFrameEvent;
FVideo.GetListOfDevices(sl);
FReady := sl.Count > 0;
if FReady then FVideo.VideoStart(sl[0])
else Suicide;
sl.Free;
end;
destructor TGrabClass.Destroy;
begin
DeallocateHWnd(Handle);
FVideo.VideoStop;
FVideo.Free;
FBitMap.Free;
inherited;
end;
Procedure TGrabClass.Suicide;
begin
// No device found Callback with empty image and Postmessage for freeing
if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
PostMessage(handle,WM_MyKill,0,0);
end;
Procedure TGrabClass.NewVideoFrameEvent(Sender : TObject; Width, Height: integer; DataPtr: pointer);
begin // we got a bitmap
FVideo.OnNewVideoFrame := Nil;
FVideo.GetBitmap(FBitMap);
if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
PostMessage(handle,WM_MyKill,0,0);
end;
procedure TGrabClass.GetImage(cb: TImageCallBack);
begin
FImageCallBack := cb;
end;
end.

Delphi XE2 - Access violation in loadfromfile pngimage

I have a listbox of images that normally works fine, but today it throws a access violation for no apparent reason.
Here is my code:
procedure TfrmSelectIcon.ListBox1DrawItem(Control: TWinControl; Index: integer;
Rect: TRect; State: TOwnerDrawState);
var
icone: TImageItem; // Ticone;
png1: TPngImage;
ImageIcone: TPngImage;
TextPosition: integer;
nomearquivo: string;
Images: TImageList;
begin
icone := TImageItem(listaIcone.Items[StrToInt(TListBox(Control).Items.Strings
[Index])]);
// Ticone(listaIcone.Items[strtoint(TListBox(Control).Items.Strings[Index])]);
nomearquivo := Diretorio + icone.arquivo;
// ShowMessage(nomearquivo);
TListBox(Control).Canvas.FillRect(Rect);
if FileExists(nomearquivo) then
begin
png1 := TPngImage.Create;
png1.LoadFromFile(nomearquivo); //here happen the problem.
png1.Draw(TListBox(Control).Canvas, Rect);
end;
end;
The file exists and it's a .png.
The bug happens just on the fifth image.
You have a memory leak, as you are not freeing the TPngImage objects you create. But worse, you should NOT be loading image files during a drawing operation to begin with. You should instead load the images once beforehand and then reuse them each time an item need to be drawn.
Try something more like this:
private
Images: array of TPngImage; // or any other container you want to use
...
procedure TfrmSelectIcon.FormDestroy(Sener: TObject);
var
I: Integer;
begin
for I := 0 to High(Images) do
Images[I].Free;
end;
procedure TfrmSelectIcon.ListBox1DrawItem(Control: TWinControl; Index: integer; Rect: TRect; State: TOwnerDrawState);
var
png: TPngImage;
begin
png := Images[Index];
if (png <> nil) and (not png.Empty) then
png1.Draw(TListBox(Control).Canvas, Rect);
end;
var
icone: TImageItem; // Ticone;
nomearquivo: string;
I: Integer;
begin
SetLength(Images, ListBox1.Items.Count);
for I := 0 to High(Images) do
Images[I] := nil;
for I := 0 to High(Images) do
begin
// personally, I would suggest storing the TImageItem pointers
// in the TListBox.Items.Objects[] property for easier access:
//
// icone := TImageItem(ListBox1.Items.Objects[I]);
//
icone := TImageItem(listaIcone.Items[StrToInt(ListBox1.Items.Strings[I])]);
nomearquivo := Diretorio + icone.arquivo;
if FileExists(nomearquivo) then
begin
try
Images[I] := TPngImage.Create;
Images[I].LoadFromFile(nomearquivo);
except
end;
end;
end;
end;
Problem solved:
TListBox(Control).Canvas.FillRect(Rect);
if FileExists(nomearquivo) then
begin
png1 := TPngImage.Create;
png1.LoadFromFile(nomearquivo);
png1.Draw(TListBox(Control).Canvas, Rect);
**FreeAndNil(png1);** //i put this line and works fine!
end;

TGifImage Transparency Issue

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.

Resources