Coming from C# and Visual Studio to Delphi 10.1 Berlin is very hard for me, but some performance is crucial, and I haven't worked with Delphi for a long time (more than 10 years), so I'm blocked.
I need to create an ImageList at run-time and store it in a singleton object, but I can't do that due to an exception while reading memory.
Here is an extract of my code:
ImagesRessource = class
private
_owner: TComponent;
_imageList: TimageList;
_man24: TPngImage;
constructor Create;
function GetBmpOf(png: TPngImage): TBitmap;
public
procedure Initialize(own: TComponent);
end;
implementation
constructor ImagesRessource.Create;
begin
;
end;
procedure ImagesRessource.Initialize(owner: TComponent);
var
bmp: TBitmap;
RS : TResourceStream;
begin
try
_man24 := TPngImage.Create;
RS := TResourceStream.Create(hInstance, 'man_24', RT_RCDATA);
_man24.LoadFromStream(RS);
bmp := GetBmpOf(_man24);
_imageList := TimageList.Create(owner);
_imageList.Width := 24;
_imageList.Height := 24;
_imageList.AddMasked(Bmp, Bmp.TransparentColor); // exception read memory here
except
raise;
end;
end;
function ImagesRessource.GetBmpOf(png: TPngImage): TBitmap;
var
bmp: TBitmap;
begin
bmp := TBitmap.Create;
bmp.Width := png.Width;
bmp.Height := png.Height;
png.Draw(bmp.Canvas, bmp.Canvas.ClipRect);
end;
What wrong here?
You don't return anything from GetBmpOf. You must assign to the Result variable.)
function ImagesRessource.GetBmpOf(png: TPngImage): TBitmap;
begin
Result := TBitmap.Create;
Result.Width := png.Width;
Result.Height := png.Height;
png.Draw(Result.Canvas, Result.Canvas.ClipRect);
end;
You also leak the PNG image _man24, which in any case should be a local variable. You hard code the size of 24 in some places but not others. Your try except block is pointless.
Related
I'm using Delphi 5 Enterprise because that's what the program I'm working with was written in. I have written a procedure which saves bitmaps to an Access database quite happily. Now I want to be able to retrieve the bitmaps. Saving the bitmaps, I use SaveToStream. Retrieving them, I used LoadFromStream but the compiler tells me that it doesn't recognise that function. The code is below:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
BMap : TBitMapImage;
begin
if BloBQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
BMap := TBitMapImage.Create;
try
Image2.Picture.Graphic := BMap.LoadFromStream(Stream);
finally
BMap.Free;
Stream.Free;
end;
end;
end;
Can anyone tell me when LoadFromStream won't work? It seems odd! Thanks.
The code which wrote the bitmap was:
procedure TForm1.Button1Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
begin
if (BlobQuery.Active = True) and (Image1.Picture.Graphic <> nil) then begin
BlobQuery.Insert;
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmWrite);
try
Image1.Picture.Graphic.SaveToStream(Stream);
finally
Stream.Free;
BlobQuery.Post;
end;
end;
end;
Assuming Image1.Picture.Graphic was pointing at a TBitmap object when you saved it to the DB, you need to use a TBitmap object instead of a TBitMapImage object when reading the image back out, eg:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
BMap : TBitmap;
begin
if BlobQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
try
BMap := TBitmap.Create;
try
BMap.LoadFromStream(Stream);
Image2.Picture.Graphic := BMap;
finally
BMap.Free;
end;
finally
Stream.Free;
end;
end;
end;
Alternatively:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
begin
if BlobQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
try
Image2.Picture.Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
end;
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 some problem with Delphi.
I was write two simple functions for make the screenshot, convert it to jpeg and decode into base64 stream.
And its works good if i make it on main stream program. But if i create a TThread class and start this function on Execute, windows freezes and i can only reboot my pc.
By making several attempts, I found that hangs PC through procedure JpegImg.SaveToStream(Input);
And if i don't convert Bitmap to jpeg, its works good, and i get the image string.
Help please.
Here a code
procedure TEvReader.ScreenShot(DestBitmap : TBitmap) ;
var DC : HDC;
begin DC := GetDC (GetDesktopWindow) ;
try
DestBitmap.Width := GetDeviceCaps (DC, HORZRES) ;
DestBitmap.Height := GetDeviceCaps (DC, VERTRES) ;
BitBlt(DestBitmap.Canvas.Handle, 0, 0, DestBitmap.Width, DestBitmap.Height, DC, 0, 0, SRCCOPY) ;
finally
ReleaseDC (GetDesktopWindow, DC) ;
end;
end;
function TEvReader.Base64FromBitmap(Bitmap: TBitmap): string;
var
Input: TBytesStream;
Output: TStringStream;
JpegImg:TJPEGImage;
begin
Input := TBytesStream.Create;
try
JpegImg:=TJPEGImage.Create;
JpegImg.Assign(Bitmap);
JpegImg.SaveToStream(Input); {here a problem.When i replace "JpegImg" to "Bitmap" all works good }
Input.Position := 0;
Output := TStringStream.Create('', TEncoding.ASCII);
try
Soap.EncdDecd.EncodeStream(Input, Output);
Result := Output.DataString;
finally
Output.Free;
end;
finally
Input.Free;
end;
end;
procedure TOutThread.Execute;
var
bmp:TBitmap;
strrr:String;
begin
bmp:=TBitmap.Create;
mObj.ScreenShot(bmp);
strrr := mObj.Base64FromBitmap(bmp);
Form2.Memo4.Text := strrr;
end;
TJPEGImage is not thread safe. While issue with thread safe drawing mentioned in http://qc.embarcadero.com/wc/qcmain.aspx?d=55871 is somewhat fixed in Delphi XE6 (by exposing Canvas property you have to lock yourself), in your case it will probably not help much.
You have to synchronize TJPEGImage handling with main thread.
Also in your code you have created some memory leaks since you have never released JpgImg and Bmp objects.
Try with following code:
procedure TEvReader.ScreenShot(DestBitmap: TBitmap);
var
DC: HDC;
begin
DC := GetDC(GetDesktopWindow);
DestBitmap.Canvas.Lock;
try
DestBitmap.Width := GetDeviceCaps(DC, HORZRES);
DestBitmap.Height := GetDeviceCaps(DC, VERTRES);
BitBlt(DestBitmap.Canvas.Handle, 0, 0, DestBitmap.Width, DestBitmap.Height, DC, 0, 0, SRCCOPY);
finally
DestBitmap.Canvas.Unlock;
ReleaseDC(GetDesktopWindow, DC);
end;
end;
function TEvReader.Base64FromBitmap(Bitmap: TBitmap): string;
var
Input: TBytesStream;
Output: TStringStream;
JpegImg: TJPEGImage;
begin
Input := TBytesStream.Create;
try
JpegImg := TJPEGImage.Create;
try
TThread.Synchronize(nil,
procedure
begin
JpegImg.Assign(Bitmap);
JpegImg.SaveToStream(Input);
end);
finally
JpegImg.Free;
end;
Input.Position := 0;
Output := TStringStream.Create('', TEncoding.ASCII);
try
Soap.EncdDecd.EncodeStream(Input, Output);
Result := Output.DataString;
finally
Output.Free;
end;
finally
Input.Free;
end;
end;
procedure TOutThread.Execute;
var
mObj: TEvReader;
bmp: TBitmap;
strrr: string;
begin
mObj := TEvReader.Create;
bmp := TBitmap.Create;
try
mObj.ScreenShot(bmp);
strrr := mObj.Base64FromBitmap(bmp);
finally
bmp.Free;
mObj.Free;
end;
Synchronize(nil,
procedure
begin
Form2.Memo4.Text := strrr;
end);
end;
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;