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;
Related
I've got a function that returns a TPicture object, from a resource stream, which loads PNGImage from a resource file.
function getImage(AName : string; lvl : integer): TPicture;
var Loader : TResourceStream;
image : TPngImage;
begin
Image := TPngImage.Create;
try begin
Loader := TResourceStream.Create(hInstance, AName+'_l'+IntToStr(lvl) , RT_RCDATA);
Loader.Position := 0;
Image.LoadFromStream(Loader);
result.Graphic := Image;
end
finally
Image.Free;
Loader.Free;
end;
end;
Can you tell me what is wrong with the code? The image object always nil, I searched the web for the answer, or any other way to load image from resources to TPicture, but found no answer that helped.
As stated in comments, your code is quite broken. It should look more like this instead:
function getImage(AName : string; lvl : integer): TPicture;
var
Loader : TResourceStream;
image : TPngImage;
begin
Result := nil;
Image := TPngImage.Create;
try
Loader := TResourceStream.Create(hInstance, AName+'_l'+IntToStr(lvl), RT_RCDATA);
try
Image.LoadFromStream(Loader);
finally
Loader.Free;
end;
Result := TPicture.Create;
try
Result.Graphic := Image;
except
Result.Free;
raise;
end;
finally
Image.Free;
end;
end;
Then the caller can do this:
var
Pic: TPicture;
begin
Pic := getImage(...);
try
// use Pic as needed...
finally
Pic.Free;
end;
end;
That being said, it is generally not a good design choice to return a new object as a function result. The caller should create the object and pass it into the function to be filled in, that way the caller can choose where the object comes from (for example, using the TImage.Picture property):
procedure getImage(AName : string; lvl : integer; APicture: TPicture);
var
Loader : TResourceStream;
image : TPngImage;
begin
APicture.Assign(nil);
Image := TPngImage.Create;
try
Loader := TResourceStream.Create(hInstance, AName+'_l'+IntToStr(lvl), RT_RCDATA);
try
Image.LoadFromStream(Loader);
finally
Loader.Free;
end;
APicture.Graphic := Image;
finally
Image.Free;
end;
end;
Then the caller can do this:
var
Pic: TPicture;
begin
Pic := TPicture.Create;
try
getImage(..., Pic);
// use Pic as needed...
finally
Pic.Free;
end;
end;
Or this:
begin
getImage(..., Image1.Picture);
end;
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;
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.
On some forms I have dbEdits that sometimes aren't wide enough to show all the text their fields may contain. For them I have the following code:
procedure Tgm12edLots.dbeLotNameMouseEnter(Sender: TObject);
begin
with dbeLotName do begin
ShowHint := True;
Hint := Text;
end;
end;
I'd like to avoid the hint showing if all the text is visible, but I don't how to test for that condition.
Thanks for any tips/suggestions!
Here is a fast version (without a TBitmap overhead) that takes into account the Edit control's Margins (i.e. EM_SETMARGINS).
Use IsEditTextOverflow below to determine if the Text overflows the visible area.
type
TCustomEditAccess = class(TCustomEdit);
function EditTextWidth(Edit: TCustomEdit): Integer;
var
DC: HDC;
Size: TSize;
SaveFont: HFont;
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, TCustomEditAccess(Edit).Font.Handle);
GetTextExtentPoint32(DC, PChar(Edit.Text), Length(Edit.Text), Size);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
Result := Size.cx;
end;
function EditVisibleWidth(Edit: TCustomEdit): Integer;
var
R: TRect;
begin
SendMessage(Edit.Handle, EM_GETRECT, 0, LPARAM(#R));
Result := R.Right - R.Left;
end;
function IsEditTextOverflow(Edit: TCustomEdit): Boolean;
begin
Result := EditTextWidth(Edit) > EditVisibleWidth(Edit);
end;
I think this should work...
function CanShowAllText(Edit: TDBEdit):Boolean;
var
TextWidth:Integer;
VisibleWidth: Integer;
Bitmap: TBitmap;
const
//This could be worked out but without delphi I can't remember all that goes into it.
BordersAndMarginsWidthEtc = 4;
begin
Bitmap := TBitmap.Create;
try
Bitmap.Canvas.Font.Assign(Edit.Font);
TextWidth := Bitmap.Canvas.TextWidth(Edit.Text);
VisibleWidth := Edit.Width - BordersAndMarginsWidthEtc;
Result := TextWidth < VisibleWidth;
finally
Bitmap.Free;
end;
end;