paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2026-02-25 07:48:46 +01:00
Code Issues Packages Projects Releases Wiki Activity

LCL: added TPicture.LoadFromStreamWithFileExt

Browse Source 
git-svn-id: trunk@13528 -
This commit is contained in:
mattias 2007-12-29 19:52:10 +00:00
parent cf4a33912a
commit d3a6947d40
2 changed files with 28 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lcl/graphics.pp
View File

@ -817,6 +817,7 @@ type
destructor Destroy; override;
procedure LoadFromFile(const Filename: string);
procedure SaveToFile(const Filename: string);
procedure LoadFromStreamWithFileExt(Stream: TStream; const FileExt: string);
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat);
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat);

27
lcl/include/picture.inc
View File

@ -512,6 +512,33 @@ begin
if FGraphic <> nil then FGraphic.SaveToFile(Filename);
end;
procedure TPicture.LoadFromStreamWithFileExt(Stream: TStream;
const FileExt: string);
var
GraphicClass: TGraphicClass;
NewGraphic: TGraphic;
ok: Boolean;
begin
GraphicClass := FindGraphicClassWithFileExt(FileExt);
NewGraphic := GraphicClass.Create;
ok:=false;
try
NewGraphic.OnProgress := @Progress;
DebugLn(['TPicture.LoadFromStreamWithFileExt ',Stream.Position,' ',Stream.Size,' ',DbgSName(Stream)]);
NewGraphic.LoadFromStream(Stream);
ok:=true;
finally
// this try..finally construction will in case of an exception
// not alter the error backtrace output
if not ok then NewGraphic.Free;
end;
FGraphic.Free;
FGraphic := NewGraphic;
FGraphic.OnChange := @Changed;
Changed(Self);
end;
procedure TPicture.LoadFromClipboardFormat(FormatID: TClipboardFormat);
begin
LoadFromClipboardFormatID(ctClipboard,FormatID);