How get size of a Jpeg? [duplicate] - delphi

I want to know the width and height of an image file before opening that file.
So, how can I do that?
This refers to JPEG, BMP, PNG and GIF types of image files.

If by 'image file' you mean those raster image files recognised by the VCL's graphics system, and by 'before opening' you mean 'before the user is likely to notice that the file is opened', then you can do this very easily:
var
pict: TPicture;
begin
with TOpenDialog.Create(nil) do
try
if Execute then
begin
pict := TPicture.Create;
try
pict.LoadFromFile(FileName);
Caption := Format('%d×%d', [pict.Width, pict.Height])
finally
pict.Free;
end;
end;
finally
Free;
end;
Of course, the file is opened, and this requires a lot of memory if the image is big. However, if you need to obtain metatada (like dimensions) without loading the file, I believe you need a more 'complicated' solution.

You can try this page. I have not tested it, but it seems pretty reasonable that it will work.
Also, different file types have different ways of getting the width and height.
One of the page answers:
unit ImgSize;
interface
uses Classes;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
implementation
uses SysUtils;
function ReadMWord(f: TFileStream): word;
type
TMotorolaWord = record
case byte of
0: (Value: word);
1: (Byte1, Byte2: byte);
end;
var
MW: TMotorolaWord;
begin
// It would probably be better to just read these two bytes in normally and
// then do a small ASM routine to swap them. But we aren't talking about
// reading entire files, so I doubt the performance gain would be worth the trouble.
f.Read(MW.Byte2, SizeOf(Byte));
f.Read(MW.Byte1, SizeOf(Byte));
Result := MW.Value;
end;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
const
ValidSig : array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
Sig: array[0..1] of byte;
f: TFileStream;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
Len: word;
ReadLen: LongInt;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
ReadLen := f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
ReadLen := 0;
if ReadLen > 0 then
begin
ReadLen := f.Read(Seg, 1);
while (Seg = $FF) and (ReadLen > 0) do
begin
ReadLen := f.Read(Seg, 1);
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) then
begin
ReadLen := f.Read(Dummy[0], 3); // don't need these bytes
wHeight := ReadMWord(f);
wWidth := ReadMWord(f);
end
else
begin
if not (Seg in Parameterless) then
begin
Len := ReadMWord(f);
f.Seek(Len - 2, 1);
f.Read(Seg, 1);
end
else
Seg := $FF; // Fake it to keep looping.
end;
end;
end;
end;
finally
f.Free;
end;
end;
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
type
TPNGSig = array[0..7] of byte;
const
ValidSig: TPNGSig = (137, 80, 78, 71, 13, 10, 26, 10);
var
Sig: TPNGSig;
f: tFileStream;
x: integer;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
exit;
f.Seek(18, 0);
wWidth := ReadMWord(f);
f.Seek(22, 0);
wHeight := ReadMWord(f);
finally
f.Free;
end;
end;
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
type
TGIFHeader = record
Sig: array[0..5] of char;
ScreenWidth, ScreenHeight: word;
Flags, Background, Aspect: byte;
end;
TGIFImageBlock = record
Left, Top, Width, Height: word;
Flags: byte;
end;
var
f: file;
Header: TGifHeader;
ImageBlock: TGifImageBlock;
nResult: integer;
x: integer;
c: char;
DimensionsFound: boolean;
begin
wWidth := 0;
wHeight := 0;
if sGifFile = '' then
exit;
{$I-}
FileMode := 0; // read-only
AssignFile(f, sGifFile);
reset(f, 1);
if IOResult <> 0 then
// Could not open file
exit;
// Read header and ensure valid file
BlockRead(f, Header, SizeOf(TGifHeader), nResult);
if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0)
or (StrLComp('GIF', Header.Sig, 3) <> 0) then
begin
// Image file invalid
close(f);
exit;
end;
// Skip color map, if there is one
if (Header.Flags and $80) > 0 then
begin
x := 3 * (1 SHL ((Header.Flags and 7) + 1));
Seek(f, x);
if IOResult <> 0 then
begin
// Color map thrashed
close(f);
exit;
end;
end;
DimensionsFound := False;
FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
// Step through blocks
BlockRead(f, c, 1, nResult);
while (not EOF(f)) and (not DimensionsFound) do
begin
case c of
',': // Found image
begin
BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
if nResult <> SizeOf(TGIFImageBlock) then
begin
// Invalid image block encountered
close(f);
exit;
end;
wWidth := ImageBlock.Width;
wHeight := ImageBlock.Height;
DimensionsFound := True;
end;
',' : // Skip
begin
// NOP
end;
// nothing else, just ignore
end;
BlockRead(f, c, 1, nResult);
end;
close(f);
{$I+}
end;
end.
And for BMP (also found at the page I mentioned):
function FetchBitmapHeader(PictFileName: String; Var wd, ht: Word): Boolean;
// similar routine is in "BitmapRegion" routine
label ErrExit;
const
ValidSig: array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
BmpSig = $4d42;
var
// Err : Boolean;
fh: HFile;
// tof : TOFSTRUCT;
bf: TBITMAPFILEHEADER;
bh: TBITMAPINFOHEADER;
// JpgImg : TJPEGImage;
Itype: Smallint;
Sig: array[0..1] of byte;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
skipLen: word;
OkBmp, Readgood: Boolean;
begin
// Open the file and get a handle to it's BITMAPINFO
OkBmp := False;
Itype := ImageType(PictFileName);
fh := CreateFile(PChar(PictFileName), GENERIC_READ, FILE_SHARE_READ, Nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (fh = INVALID_HANDLE_VALUE) then
goto ErrExit;
if Itype = 1 then
begin
// read the BITMAPFILEHEADER
if not GoodFileRead(fh, #bf, sizeof(bf)) then
goto ErrExit;
if (bf.bfType <> BmpSig) then // 'BM'
goto ErrExit;
if not GoodFileRead(fh, #bh, sizeof(bh)) then
goto ErrExit;
// for now, don't even deal with CORE headers
if (bh.biSize = sizeof(TBITMAPCOREHEADER)) then
goto ErrExit;
wd := bh.biWidth;
ht := bh.biheight;
OkBmp := True;
end
else
if (Itype = 2) then
begin
FillChar(Sig, SizeOf(Sig), #0);
if not GoodFileRead(fh, #Sig[0], sizeof(Sig)) then
goto ErrExit;
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
goto ErrExit;
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
while (Seg = $FF) and Readgood do
begin
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) or (Seg = $C2) then
begin
Readgood := GoodFileRead(fh, #Dummy[0],3); // don't need these bytes
if ReadMWord(fh, ht) and ReadMWord(fh, wd) then
OkBmp := True;
end
else
begin
if not (Seg in Parameterless) then
begin
ReadMWord(fh,skipLen);
SetFilePointer(fh, skipLen - 2, nil, FILE_CURRENT);
GoodFileRead(fh, #Seg, sizeof(Seg));
end
else
Seg := $FF; // Fake it to keep looping
end;
end;
end;
end;
ErrExit: CloseHandle(fh);
Result := OkBmp;
end;

As a complement to Rafael's answer, I believe that this much shorter procedure can detect BMP dimensions:
function GetBitmapDimensions(const FileName: string; out Width,
Height: integer): boolean;
const
BMP_MAGIC_WORD = ord('M') shl 8 or ord('B');
var
f: TFileStream;
header: TBitmapFileHeader;
info: TBitmapInfoHeader;
begin
result := false;
f := TFileStream.Create(FileName, fmOpenRead);
try
if f.Read(header, sizeof(header)) <> sizeof(header) then Exit;
if header.bfType <> BMP_MAGIC_WORD then Exit;
if f.Read(info, sizeof(info)) <> sizeof(info) then Exit;
Width := info.biWidth;
Height := abs(info.biHeight);
result := true;
finally
f.Free;
end;
end;

If anyone yet interested in retrieving TIFF image dimensions without loading the graphic, there is a proven method that works perfectly for me in all environments. I also found another solution for that, but it returned wrong values from Illustrator-generated TIFFs. But there is a fantastic graphic library, called GraphicEx by Mike Lischke (TVirtualStringTree's very talented developer). There are implementations of many popular image formats and all of them descend from the base class TGraphicExGraphic, that implements ReadImageProperties virtual method. It is stream-based and only reads the fileheader in all implementations. So it is lightning-fast... :-)
So, here is a sample code, that retrieves a TIFF's dimensions (the method is the same for all graphic implementation, PNG,PCD,TGA,GIF,PCX,etc):
Uses ..., GraphicEx,...,...;
Procedure ReadTifSize (FN:String; Var iWidth,iHeight:Integer);
Var FS:TFileStream;
TIFF:TTIFFGraphic;
Begin
iWidth:=0;iHeight:=0;
TIFF:=TTIFFGraphic.Create;
FS:=TFileStream.Create(FN,OF_READ);
Try
TIFF.ReadImageProperties(FS,0);
iWidth:=TIFF.ImageProperties.Width;
iHeight:=TIFF.ImageProperties.Height;
Finally
TIFF.Destroy;
FS.Free;
End;
End;
That's all... :-) And this is the same for all the graphic implementations in the unit.

I don't like Rafael's solution for JPEG files too much because his algorithm parses every single byte until it hits FFC0. It doesn't make use of the fact that almost all markers (except FFD8, FFD9 and FFFE) are followed by two length bytes, allowing to skip from marker to marker. So I suggest the following procedure (which I condensed even a little more by stuffing checking for a marker and retrieving a value into the same function):
procedure GetJPGSize(const Filename: string; var ImgWidth, ImgHeight: word);
const
SigJPG : TBytes = [$FF, $D8];
SigC01 : TBytes = [$FF, $C0];
SigC02 : TBytes = [$FF, $C1];
var
FStream: TFileStream;
Buf: array[0..1] of Byte;
Offset,CheckMarker : Word;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function SameValue(Sig:TBytes):Boolean;
begin
Result := CompareMem(#Sig[0], #Buf[0], Length(Sig));
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function CheckMarkerOrVal(var Value:Word):Boolean;
begin
FStream.ReadData(Buf, Length(Buf));
Value := Swap(PWord(#Buf[0])^);
Result := (Buf[0] = $FF);
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
begin
FStream := TFileStream.Create(Filename, fmOpenRead);
Try
// First two bytes in a JPG file MUST be $FFD8, followed by the next marker
If not (CheckMarkerOrVal(CheckMarker) and SameValue(SigJPG))
then exit;
Repeat
If not CheckMarkerOrVal(CheckMarker)
then exit;
If SameValue(SigC01) or SameValue(SigC02) then begin
FStream.Position := FStream.Position + 3;
CheckMarkerOrVal(ImgHeight);
CheckMarkerOrVal(ImgWidth);
exit;
end;
CheckMarkerOrVal(Offset);
FStream.Position := FStream.Position + Offset - 2;
until FStream.Position > FStream.Size div 2;
Finally
FStream.Free;
end;
end;

Since GetGIFSize in Rafael's answer is broken and utterly complicated, here is my personal version of it:
function GetGifSize(var Stream: TMemoryStream; var Width: Word; var Height: Word): Boolean;
var
HeaderStr: AnsiString;
begin
Result := False;
Width := 0;
Height := 0;
//GIF header is 13 bytes in length
if Stream.Size > 13 then
begin
SetString(HeaderStr, PAnsiChar(Stream.Memory), 6);
if (HeaderStr = 'GIF89a') or (HeaderStr = 'GIF87a') then
begin
Stream.Seek(6, soFromBeginning);
Stream.Read(Width, 2); //Width is located at bytes 7-8
Stream.Read(Height, 2); //Height is located at bytes 9-10
Result := True;
end;
end;
end;
I found it by reading the RFC.

Related

How to detect animated GIF?

I need to detect if a GIF file is animated (more than one frame) or not. Maybe the number of frames is written somewhere in the header of the GIF file?
A very ugly (slow) solution is to load the whole GIF (Vcl.Imaging.GIFImg.TGIFImage.LoadFromFile) and then to check if there is more than one frame. However, for large GIF files this takes seconds.
To improve speed I made a duplicate of that file and I removed some code from LoadFromStream. Of course, the image itself won't decode properly but I don't care. I only need the frame count. And it works:
procedure TGIFImage.LoadFromStream(Stream: TStream);
var
Position: integer;
begin
try
InternalClear;
Position := Stream.Position;
try
FHeader.LoadFromStream(Stream);
FImages.LoadFromStream(Stream);
{ This makes the loading slow:
with TGIFTrailer.Create(Self) do
try
LoadFromStream(Stream);
finally
Free;
end;
Changed(Self);
}
except
Stream.Position := Position;
raise;
end;
finally
end;
end;
Now the loading is only 600ms instead of 6 sec.
How do I use this modified LoadFromStream procedure, without using a full duplicate GIFImg.pas file?
How do I use this modified LoadFromStream procedure, without using a
full duplicate GIFImg.pas file?
Since the classes/methods in the code excerpt you display are not hidden in private/implementation sections, the best course of action would be to write code that duplicates relevant functionality.
Sample implementation can be like the below:
uses
gifimg;
function GifFrameCount(const FileName: string): Integer;
var
Img: TGifImage;
Header: TGIFHeader;
Stream: TFileStream;
Images: TGIFImageList;
begin
Img := TGIFImage.Create;
try
Header := TGIFHeader.Create(Img);
try
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Header.LoadFromStream(Stream);
Images := TGIFImageList.Create(Img);
try
Images.LoadFromStream(Stream);
Result := Images.Image.Images.Count;
finally
Images.Free;
end;
finally
Stream.Free;
end;
finally
Header.Free;
end;
finally
Img.Free;
end;
end;
The function raises an exception for a non-gif file, otherwise returns the frame count.
This FMX library (link1 link2) reads animated gif files. It is much simpler than the VCL one but it does the job well.
I converted the library to VCL.
Clean up
Basically, we need only the GIF structure parser. The frame decoder code (the one that makes the library slow) can be removed.
We can delete:
the TGifFrameList and all code related to it.
all frame decoding code
some of the utility functions like MergeBitmap.
Getting the frame count
In TGifReader.Read procedure there is a var called FrameIndex. Make that public and interrogate it to obtain the final frame count.
You will end up with only a few hundred lines of code. Pretty clean.
Speed
The speed after clean up is impressive.
The execution time is about 650ms for a 50MB gif (199 frames).
I tested the library with about 50 gif files (static and animated).
unit GifParser;
{---------------------------------------------------
The purpose of this unit is to return the FrameGount of an animated gif.
This was converted from FMX.
It will not decode the actual frames!
Originally this was for animated gif in Firemonkey
Pointing: https://stackoverflow.com/questions/45285599/how-to-use-animated-gif-in-firemonkey
Original original code: http://www.raysoftware.cn/?p=559
-------------------------------------------------------------------------------------------------------------}
INTERFACE
USES
System.Classes, System.SysUtils, System.Types, System.UITypes, Vcl.Graphics;
{ 100mb Animated Elementalist Lux Desktop Background.gif = 4.1s }
function IsAnimatedGif(CONST FileName: string): Integer;
TYPE
TGifVer = (verUnknow, ver87a, ver89a);
TInternalColor = packed record
case Integer of
0: (
{$IFDEF BIGENDIAN} R, G, B, A: Byte;
{$ELSE} B, G, R, A: Byte;
{$ENDIF} );
1: (Color: TAlphaColor; );
end;
{$POINTERMATH ON}
PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}
TGifRGB = packed record
R: Byte;
G: Byte;
B: Byte;
end;
TGIFHeaderX = packed record
Signature: array [0 .. 2] of Byte; // * Header Signature (always "GIF") */
Version: array [0 .. 2] of Byte; // * GIF format version("87a" or "89a") */
// Logical Screen Descriptor
ScreenWidth : word; // * Width of Display Screen in Pixels */
ScreenHeight: word; // * Height of Display Screen in Pixels */
Packedbit: Byte; // * Screen and Color Map Information */
BackgroundColor: Byte; // * Background Color Index */
AspectRatio: Byte; // * Pixel Aspect Ratio */
end;
TGifImageDescriptor = packed record
Left: word; // * X position of image on the display */
Top: word; // * Y position of image on the display */
Width: word; // * Width of the image in pixels */
Height: word; // * Height of the image in pixels */
Packedbit: Byte; // * Image and Color Table Data Information */
end;
TGifGraphicsControlExtension = packed record
BlockSize: Byte; // * Size of remaining fields (always 04h) */
Packedbit: Byte; // * Method of graphics disposal to use */
DelayTime: word; // * Hundredths of seconds to wait */
ColorIndex: Byte; // * Transparent Color Index */
Terminator: Byte; // * Block Terminator (always 0) */
end;
TPalette = TArray<TInternalColor>;
{ TGifReader }
TGifReader = class(TObject)
protected
FHeader: TGIFHeaderX;
FPalette: TPalette;
FScreenWidth: Integer;
FScreenHeight: Integer;
FBitsPerPixel: Byte;
FBackgroundColorIndex: Byte;
FResolution: Byte;
FGifVer: TGifVer;
function Read(Stream: TStream): Boolean; overload; virtual;
public
Interlace: Boolean;
FrameIndex: Integer;
function Read(FileName: string): Boolean; overload; virtual;
function Check(Stream: TStream): Boolean; overload; virtual;
function Check(FileName: string): Boolean; overload; virtual;
public
constructor Create; virtual;
property Header: TGIFHeaderX read FHeader;
property ScreenWidth: Integer read FScreenWidth;
property ScreenHeight: Integer read FScreenHeight;
property BitsPerPixel: Byte read FBitsPerPixel;
property Resolution: Byte read FResolution;
property GifVer: TGifVer read FGifVer;
end;
IMPLEMENTATION
USES
Math;
{ 100mb Animated Elementalist Lux Desktop Background.gif = 4.1s }
function IsAnimatedGif(CONST FileName: string): integer;
VAR
GIFImg: TGifReader;
begin
GIFImg := TGifReader.Create;
TRY
GIFImg.Read(FileName);
Result:= GIFImg.FrameIndex; //GifFrameList.Count;
FINALLY
FreeAndNil(GIFImg);
END;
end;
CONST
alphaTransparent = $00;
GifSignature : array [0 .. 2] of Byte = ($47, $49, $46); // GIF
VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a
function swap16(x: UInt16): UInt16; inline;
begin
Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;
function swap32(x: UInt32): UInt32; inline;
begin
Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;
function LEtoN(Value: word): word; overload;
begin
Result := swap16(Value);
end;
function LEtoN(Value: Dword): Dword; overload;
begin
Result := swap32(Value);
end;
{ TGifReader }
function TGifReader.Read(FileName: string): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Read(fs);
except
end;
fs.DisposeOf;
end;
function TGifReader.Read(Stream: TStream): Boolean;
var
LDescriptor: TGifImageDescriptor;
LGraphicsCtrlExt: TGifGraphicsControlExtension;
LIsTransparent: Boolean;
LGraphCtrlExt: Boolean;
LFrameWidth: Integer;
LFrameHeight: Integer;
LLocalPalette: TPalette;
LScanLineBuf: TBytes;
procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
Var
RGBEntry: TGifRGB;
I: Integer;
begin
SetLength(APalette, Size);
For I := 0 To Size - 1 Do
Stream.Read(RGBEntry, SizeOf(RGBEntry));
end;
function ProcHeader: Boolean;
begin
With FHeader do
begin
if (CompareMem(#Signature, #GifSignature, 3)) and
(CompareMem(#Version, #VerSignature87a, 3)) or
(CompareMem(#Version, #VerSignature89a, 3)) then
begin
FScreenWidth := FHeader.ScreenWidth;
FScreenHeight := FHeader.ScreenHeight;
FResolution := Packedbit and $70 shr 5 + 1;
FBitsPerPixel := Packedbit and 7 + 1;
FBackgroundColorIndex := BackgroundColor;
if CompareMem(#Version, #VerSignature87a, 3) then
FGifVer := ver87a
else if CompareMem(#Version, #VerSignature89a, 3) then
FGifVer := ver89a;
Result := True;
end
else
Raise Exception.Create('Unknown GIF image format');
end;
end;
function ProcFrame: Boolean;
var
LineSize: Integer;
LBackColorIndex: Integer;
begin
LBackColorIndex:= 0;
With LDescriptor do
begin
LFrameWidth := Width;
LFrameHeight := Height;
Interlace := ((Packedbit and $40) = $40);
end;
if LGraphCtrlExt then
begin
LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
If LIsTransparent then
LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
end
else
begin
LIsTransparent := FBackgroundColorIndex <> 0;
LBackColorIndex := FBackgroundColorIndex;
end;
LineSize := LFrameWidth * (LFrameHeight + 1);
SetLength(LScanLineBuf, LineSize);
If LIsTransparent
then LLocalPalette[LBackColorIndex].A := alphaTransparent;
Result := True;
end;
function ReadAndProcBlock(Stream: TStream): Byte;
var
Introducer, Labels, SkipByte: Byte;
begin
Stream.Read(Introducer, 1);
if Introducer = $21 then
begin
Stream.Read(Labels, 1);
Case Labels of
$FE, $FF:
// Comment Extension block or Application Extension block
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
$F9: // Graphics Control Extension block
begin
Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
LGraphCtrlExt := True;
end;
$01: // Plain Text Extension block
begin
Stream.Read(SkipByte, 1);
Stream.Seek(Int64( SkipByte), soFromCurrent);
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
end;
end;
end;
Result := Introducer;
end;
function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
var
OldPos, PackedSize: longint;
I: Integer;
SourcePtr: PByte;
Prefix: array [0 .. 4095] of Cardinal;
Suffix: array [0 .. 4095] of Byte;
DataComp: TBytes;
B, FInitialCodeSize: Byte;
ClearCode: word;
begin
DataComp := nil;
try
try
Stream.Read(FInitialCodeSize, 1);
OldPos := Stream.Position;
PackedSize := 0;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Inc(PackedSize, B);
Stream.Seek(Int64(B), soFromCurrent);
end;
until B = 0;
SetLength(DataComp, 2 * PackedSize);
SourcePtr := #DataComp[0];
Stream.Position := OldPos;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Stream.ReadBuffer(SourcePtr^, B);
Inc(SourcePtr, B);
end;
until B = 0;
ClearCode := 1 shl FInitialCodeSize;
for I := 0 to ClearCode - 1 do
begin
Prefix[I] := 4096;
Suffix[I] := I;
end;
finally
DataComp := nil;
end;
except
end;
Result := True;
end;
VAR
Introducer: Byte;
ColorTableSize: Integer;
rendered : array of TBitmap;
begin
Result := False;
FrameIndex:= 0;
if not Check(Stream) then Exit;
FGifVer := verUnknow;
FPalette := nil;
LScanLineBuf := nil;
TRY
Stream.Position := 0;
Stream.Read(FHeader, SizeOf(FHeader));
{$IFDEF BIGENDIAN}
with FHeader do
begin
ScreenWidth := LEtoN(ScreenWidth);
ScreenHeight := LEtoN(ScreenHeight);
end;
{$ENDIF}
if (FHeader.Packedbit and $80) = $80 then
begin
ColorTableSize := FHeader.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
end;
if not ProcHeader then
Exit;
FrameIndex := 0;
while True do
begin
LLocalPalette := nil;
Repeat
Introducer := ReadAndProcBlock(Stream);
until (Introducer in [$2C, $3B]);
if Introducer = $3B then
Break;
Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
nope
with FDescriptor do
begin
Left := LEtoN(Left);
Top := LEtoN(Top);
Width := LEtoN(Width);
Height := LEtoN(Height);
end;
{$ENDIF}
if (LDescriptor.Packedbit and $80) <> 0 then
begin
ColorTableSize := LDescriptor.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
end
else
LLocalPalette := Copy(FPalette, 0, Length(FPalette));
if not ProcFrame then EXIT;
if not ReadScanLine(Stream, #LScanLineBuf[0]) then EXIT;
Inc(FrameIndex);
end;
Result := True;
finally
LLocalPalette := nil;
LScanLineBuf := nil;
rendered := nil;
end;
end;
function TGifReader.Check(Stream: TStream): Boolean;
var
OldPos: Int64;
begin
try
OldPos := Stream.Position;
Stream.Read(FHeader, SizeOf(FHeader));
Result := (CompareMem(#FHeader.Signature, #GifSignature, 3)) and
(CompareMem(#FHeader.Version, #VerSignature87a, 3)) or
(CompareMem(#FHeader.Version, #VerSignature89a, 3));
Stream.Position := OldPos;
except
Result := False;
end;
end;
function TGifReader.Check(FileName: string): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Check(fs);
except
end;
fs.DisposeOf;
end;
constructor TGifReader.Create;//delete
begin
inherited Create;
end;
end.

How to use animated gif in Firemonkey?

How can I use animated GIF in Firemonky. I can load the gif using Timage but it's not animating. I am using Delphi 10.2 tokyo.
Maybe a bit late, but found a simple solution on this page :
http://www.raysoftware.cn/?p=559
Download the file http://www.raysoftware.cn/wp-content/uploads/2016/12/FMXGif.rar, uncompress, and take the file FMX.GifUtils out, and put in your the directory of your application
Put a image component on your form with name Image1
Put the file FMX.GifUtils in your use on top
Declare in your form in private :
FGifPlayer: TGifPlayer;
in the create of your form:
FGifPlayer := TGifPlayer.Create(Self);
FGifPlayer.Image := Image1;
FGifPlayer.LoadFromFile('youfilename.gif');
FGifPlayer.Play;
That's it;
Use TBitmapListAnimation.
Place TImage on Form
Place TBitmapListAnimation into TImage like on screenshot:
Set properties in TBitmapListAnimation
AnimationBitmap -
You can use online convertorsm that split gif into frames.
http://ezgif.com/split
http://www.photojoiner.net/merge-photos/editor/#
Set another properties:
AnimationCount = 8, AnimationRowCount = 1,
Enabled = True
Duration in seconds,
PropertyName = Bitmap.
Please vote if you like this answer.
P.s. How to create an animation bitmap from a list of images to use in TBitmapListAnimation?
Download this app, here is also a topic.
Here is another one solution.
Unit from previous answer http://www.raysoftware.cn, but with fixed bugs
unit FMX.GifUtils;
interface
uses
System.Classes, System.SysUtils, System.Types, System.UITypes,
FMX.Types, FMX.Objects, FMX.Graphics, System.Generics.Collections;
const
alphaTransparent = $00;
GifSignature: array [0 .. 2] of Byte = ($47, $49, $46); // GIF
VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a
GIF_DISPOSAL_UNSPECIFIED = 0;
GIF_DISPOSAL_LEAVE = 1;
GIF_DISPOSAL_BACKGROUND = 2;
GIF_DISPOSAL_PREVIOUS = 3;
type
TGifVer = (verUnknow, ver87a, ver89a);
TInternalColor = packed record
case Integer of
0:
(
{$IFDEF BIGENDIAN}
R, G, B, A: Byte;
{$ELSE}
B, G, R, A: Byte;
{$ENDIF}
);
1:
(Color: TAlphaColor;
);
end;
{$POINTERMATH ON}
PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}
TGifRGB = packed record
R: Byte;
G: Byte;
B: Byte;
end;
TGIFHeader = packed record
Signature: array [0 .. 2] of Byte; // * Header Signature (always "GIF") */
Version: array [0 .. 2] of Byte; // * GIF format version("87a" or "89a") */
// Logical Screen Descriptor
ScreenWidth: word; // * Width of Display Screen in Pixels */
ScreenHeight: word; // * Height of Display Screen in Pixels */
Packedbit: Byte; // * Screen and Color Map Information */
BackgroundColor: Byte; // * Background Color Index */
AspectRatio: Byte; // * Pixel Aspect Ratio */
end;
TGifImageDescriptor = packed record
Left: word; // * X position of image on the display */
Top: word; // * Y position of image on the display */
Width: word; // * Width of the image in pixels */
Height: word; // * Height of the image in pixels */
Packedbit: Byte; // * Image and Color Table Data Information */
end;
TGifGraphicsControlExtension = packed record
BlockSize: Byte; // * Size of remaining fields (always 04h) */
Packedbit: Byte; // * Method of graphics disposal to use */
DelayTime: word; // * Hundredths of seconds to wait */
ColorIndex: Byte; // * Transparent Color Index */
Terminator: Byte; // * Block Terminator (always 0) */
end;
TGifReader = class;
TPalette = TArray<TInternalColor>;
TGifFrameItem = class;
TGifFrameList = TObjectList<TGifFrameItem>;
{ TGifReader }
TGifReader = class(TObject)
protected
FHeader: TGIFHeader;
FPalette: TPalette;
FScreenWidth: Integer;
FScreenHeight: Integer;
FInterlace: Boolean;
FBitsPerPixel: Byte;
FBackgroundColorIndex: Byte;
FResolution: Byte;
FGifVer: TGifVer;
public
function Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean;
overload; virtual;
function Read(FileName: string; var AFrameList: TGifFrameList): Boolean;
overload; virtual;
function ReadRes(Instance: THandle; ResName: string; ResType: PChar;
var AFrameList: TGifFrameList): Boolean; overload; virtual;
function ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
var AFrameList: TGifFrameList): Boolean; overload; virtual;
function Check(Stream: TStream): Boolean; overload; virtual;
function Check(FileName: string): Boolean; overload; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
property Header: TGIFHeader read FHeader;
property ScreenWidth: Integer read FScreenWidth;
property ScreenHeight: Integer read FScreenHeight;
property Interlace: Boolean read FInterlace;
property BitsPerPixel: Byte read FBitsPerPixel;
property Background: Byte read FBackgroundColorIndex;
property Resolution: Byte read FResolution;
property GifVer: TGifVer read FGifVer;
end;
TGifFrameItem = class
FDisposalMethod: Integer;
FPos: TPoint;
FTime: Integer;
FDisbitmap: TBitmap;
fBackColor : TalphaColor;
public
destructor Destroy; override;
property Bitmap : TBitmap read FDisbitmap;
end;
implementation
uses
Math;
function swap16(x: UInt16): UInt16; inline;
begin
Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;
function swap32(x: UInt32): UInt32; inline;
begin
Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;
function LEtoN(Value: word): word; overload;
begin
Result := swap16(Value);
end;
function LEtoN(Value: Dword): Dword; overload;
begin
Result := swap32(Value);
end;
procedure MergeBitmap(const Source, Dest: TBitmap; SrcRect: TRect;
DestX, DestY: Integer);
var
I, J, MoveBytes: Integer;
SrcData, DestData: TBitmapData;
lpColorSrc, lpColorDst: PInternalColor;
begin
With Dest do
begin
if Map(TMapAccess.Write, DestData) then
try
if Source.Map(TMapAccess.Read, SrcData) then
try
if SrcRect.Left < 0 then
begin
Dec(DestX, SrcRect.Left);
SrcRect.Left := 0;
end;
if SrcRect.Top < 0 then
begin
Dec(DestY, SrcRect.Top);
SrcRect.Top := 0;
end;
SrcRect.Right := Min(SrcRect.Right, Source.Width);
SrcRect.Bottom := Min(SrcRect.Bottom, Source.Height);
if DestX < 0 then
begin
Dec(SrcRect.Left, DestX);
DestX := 0;
end;
if DestY < 0 then
begin
Dec(SrcRect.Top, DestY);
DestY := 0;
end;
if DestX + SrcRect.Width > Width then
SrcRect.Width := Width - DestX;
if DestY + SrcRect.Height > Height then
SrcRect.Height := Height - DestY;
if (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom)
then
begin
MoveBytes := SrcRect.Width * SrcData.BytesPerPixel;
for I := 0 to SrcRect.Height - 1 do
begin
lpColorSrc := SrcData.GetPixelAddr(SrcRect.Left,
SrcRect.Top + I);
lpColorDst := DestData.GetPixelAddr(DestX, DestY + I);
for J := 0 to SrcRect.Width - 1 do
if lpColorSrc[J].A <> 0 then
begin
lpColorDst[J] := lpColorSrc[J];
end;
end;
end;
finally
Source.Unmap(SrcData);
end;
finally
Unmap(DestData);
end;
end;
end;
{ TGifReader }
function TGifReader.Read(FileName: string;
var AFrameList: TGifFrameList): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Read(fs, AFrameList);
except
end;
fs.DisposeOf;
end;
function TGifReader.ReadRes(Instance: THandle; ResName: string; ResType: PChar;
var AFrameList: TGifFrameList): Boolean;
var
res: TResourceStream;
begin
res := TResourceStream.Create(HInstance, ResName, ResType);
Result := Read(res, AFrameList);
res.DisposeOf;
end;
function TGifReader.ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
var AFrameList: TGifFrameList): Boolean;
var
res: TResourceStream;
begin
res := TResourceStream.CreateFromID(HInstance, ResId, ResType);
Result := Read(res, AFrameList);
res.DisposeOf;
end;
function TGifReader.Read(Stream: TStream;
var AFrameList: TGifFrameList): Boolean;
var
LDescriptor: TGifImageDescriptor;
LGraphicsCtrlExt: TGifGraphicsControlExtension;
LIsTransparent: Boolean;
LGraphCtrlExt: Boolean;
LFrameWidth: Integer;
LFrameHeight: Integer;
LLocalPalette: TPalette;
LScanLineBuf: TBytes;
procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
Var
RGBEntry: TGifRGB;
I: Integer;
c: TInternalColor;
begin
SetLength(APalette, Size);
For I := 0 To Size - 1 Do
Begin
Stream.Read(RGBEntry, SizeOf(RGBEntry));
With APalette[I] do
begin
R := RGBEntry.R or (RGBEntry.R shl 8);
G := RGBEntry.G or (RGBEntry.G shl 8);
B := RGBEntry.B or (RGBEntry.B shl 8);
A := $FF;
end;
End;
end;
function ProcHeader: Boolean;
var
c: TInternalColor;
begin
Result := False;
With FHeader do
begin
if (CompareMem(#Signature, #GifSignature, 3)) and
(CompareMem(#Version, #VerSignature87a, 3)) or
(CompareMem(#Version, #VerSignature89a, 3)) then
begin
FScreenWidth := FHeader.ScreenWidth;
FScreenHeight := FHeader.ScreenHeight;
FResolution := Packedbit and $70 shr 5 + 1;
FBitsPerPixel := Packedbit and 7 + 1;
FBackgroundColorIndex := BackgroundColor;
if CompareMem(#Version, #VerSignature87a, 3) then
FGifVer := ver87a
else if CompareMem(#Version, #VerSignature89a, 3) then
FGifVer := ver89a;
Result := True;
end
else
Raise Exception.Create('Unknown GIF image format');
end;
end;
function ProcFrame: Boolean;
var
LineSize: Integer;
LBackColorIndex: Integer;
begin
Result := False;
With LDescriptor do
begin
LFrameWidth := Width;
LFrameHeight := Height;
FInterlace := ((Packedbit and $40) = $40);
end;
if LGraphCtrlExt then
begin
LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
If LIsTransparent then
LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
end
else
begin
LIsTransparent := FBackgroundColorIndex <> 0;
LBackColorIndex := FBackgroundColorIndex;
end;
LineSize := LFrameWidth * (LFrameHeight + 1);
SetLength(LScanLineBuf, LineSize);
If LIsTransparent then
begin
LLocalPalette[LBackColorIndex].A := alphaTransparent;
end;
Result := True;
end;
function ReadAndProcBlock(Stream: TStream): Byte;
var
Introducer, Labels, SkipByte: Byte;
begin
Stream.Read(Introducer, 1);
if Introducer = $21 then
begin
Stream.Read(Labels, 1);
Case Labels of
$FE, $FF:
// Comment Extension block or Application Extension block
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
$F9: // Graphics Control Extension block
begin
Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
LGraphCtrlExt := True;
end;
$01: // Plain Text Extension block
begin
Stream.Read(SkipByte, 1);
Stream.Seek(Int64( SkipByte), soFromCurrent);
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
end;
end;
end;
Result := Introducer;
end;
function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
var
OldPos, UnpackedSize, PackedSize: longint;
I: Integer;
Data, Bits, Code: Cardinal;
SourcePtr: PByte;
InCode: Cardinal;
CodeSize: Cardinal;
CodeMask: Cardinal;
FreeCode: Cardinal;
OldCode: Cardinal;
Prefix: array [0 .. 4095] of Cardinal;
Suffix, Stack: array [0 .. 4095] of Byte;
StackPointer: PByte;
Target: PByte;
DataComp: TBytes;
B, FInitialCodeSize, FirstChar: Byte;
ClearCode, EOICode: word;
begin
DataComp := nil;
try
try
Stream.Read(FInitialCodeSize, 1);
OldPos := Stream.Position;
PackedSize := 0;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Inc(PackedSize, B);
Stream.Seek(Int64(B), soFromCurrent);
CodeMask := (1 shl CodeSize) - 1;
end;
until B = 0;
SetLength(DataComp, 2 * PackedSize);
SourcePtr := #DataComp[0];
Stream.Position := OldPos;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Stream.ReadBuffer(SourcePtr^, B);
Inc(SourcePtr, B);
end;
until B = 0;
SourcePtr := #DataComp[0];
Target := AScanLine;
CodeSize := FInitialCodeSize + 1;
ClearCode := 1 shl FInitialCodeSize;
EOICode := ClearCode + 1;
FreeCode := ClearCode + 2;
OldCode := 4096;
CodeMask := (1 shl CodeSize) - 1;
UnpackedSize := LFrameWidth * LFrameHeight;
for I := 0 to ClearCode - 1 do
begin
Prefix[I] := 4096;
Suffix[I] := I;
end;
StackPointer := #Stack;
FirstChar := 0;
Data := 0;
Bits := 0;
while (UnpackedSize > 0) and (PackedSize > 0) do
begin
Inc(Data, SourcePtr^ shl Bits);
Inc(Bits, 8);
while Bits >= CodeSize do
begin
Code := Data and CodeMask;
Data := Data shr CodeSize;
Dec(Bits, CodeSize);
if Code = EOICode then
Break;
if Code = ClearCode then
begin
CodeSize := FInitialCodeSize + 1;
CodeMask := (1 shl CodeSize) - 1;
FreeCode := ClearCode + 2;
OldCode := 4096;
Continue;
end;
if Code > FreeCode then
Break;
if OldCode = 4096 then
begin
FirstChar := Suffix[Code];
Target^ := FirstChar;
Inc(Target);
Dec(UnpackedSize);
OldCode := Code;
Continue;
end;
InCode := Code;
if Code = FreeCode then
begin
StackPointer^ := FirstChar;
Inc(StackPointer);
Code := OldCode;
end;
while Code > ClearCode do
begin
StackPointer^ := Suffix[Code];
Inc(StackPointer);
Code := Prefix[Code];
end;
FirstChar := Suffix[Code];
StackPointer^ := FirstChar;
Inc(StackPointer);
Prefix[FreeCode] := OldCode;
Suffix[FreeCode] := FirstChar;
if (FreeCode = CodeMask) and (CodeSize < 12) then
begin
Inc(CodeSize);
CodeMask := (1 shl CodeSize) - 1;
end;
if FreeCode < 4095 then
Inc(FreeCode);
OldCode := InCode;
repeat
Dec(StackPointer);
Target^ := StackPointer^;
Inc(Target);
Dec(UnpackedSize);
until StackPointer = #Stack;
end;
Inc(SourcePtr);
Dec(PackedSize);
end;
finally
DataComp := nil;
end;
except
end;
Result := True;
end;
function WriteScanLine(var Img: TBitmap; AScanLine: PByte): Boolean;
Var
Row, Col: Integer;
Pass, Every: Byte;
P: PByte;
function IsMultiple(NumberA, NumberB: Integer): Boolean;
begin
Result := (NumberA >= NumberB) and (NumberB > 0) and
(NumberA mod NumberB = 0);
end;
var
PLine: PInternalColor;
Data: TBitmapData;
begin
Result := False;
P := AScanLine;
if Img.Map(TMapAccess.Write, Data) then
begin
try
If FInterlace then
begin
For Pass := 1 to 4 do
begin
Case Pass of
1:
begin
Row := 0;
Every := 8;
end;
2:
begin
Row := 4;
Every := 8;
end;
3:
begin
Row := 2;
Every := 4;
end;
4:
begin
Row := 1;
Every := 2;
end;
end;
Repeat
PLine := Data.GetScanline(Row);
for Col := 0 to Img.Width - 1 do
begin
PLine[Col] := LLocalPalette[P^];
Inc(P);
end;
Inc(Row, Every);
until Row >= Img.Height;
end;
end
else
begin
for Row := 0 to Img.Height - 1 do
begin
PLine := Data.GetScanline(Row);
for Col := 0 to Img.Width - 1 do
begin
PLine[Col] := LLocalPalette[P^];
Inc(P);
end;
end;
end;
Result := True;
finally
Img.Unmap(Data);
end;
end;
end;
procedure RenderFrame(const Index : integer; const aFrames : array of TGifFrameItem; const aDisplay : TBitmap);
var
I, First, Last: Integer;
begin
Last := Index;
First := Max(0, Last);
aDisplay.Clear(aFrames[Index].fBackColor);
while First > 0 do
begin
if (fScreenWidth = aFrames[First].Bitmap.Width) and (fScreenHeight = aFrames[First].Bitmap.Height) then
begin
if (aFrames[First].FDisposalMethod = GIF_DISPOSAL_BACKGROUND) and (First < Last) then
Break;
end;
Dec(First);
end;
for I := First to Last - 1 do
begin
case aFrames[I].FDisposalMethod of
GIF_DISPOSAL_UNSPECIFIED,
GIF_DISPOSAL_LEAVE:
begin
// Copy previous raw frame onto screen
MergeBitmap(aFrames[i].Bitmap, aDisplay, aFrames[i].Bitmap.Bounds,
aFrames[i].FPos.X, aFrames[i].FPos.Y);
end;
GIF_DISPOSAL_BACKGROUND:
if (I > First) then
begin
// Restore background color
aDisplay.ClearRect(TRectF.Create(aFrames[i].FPos.X, aFrames[i].FPos.Y,
aFrames[i].FPos.X + aFrames[i].Bitmap.Width,
aFrames[i].FPos.Y + aFrames[i].Bitmap.Height),
aFrames[i].fBackColor);
end;
GIF_DISPOSAL_PREVIOUS: ; // Do nothing - previous state is already on screen
end;
end;
MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);
end;
var
Introducer: Byte;
ColorTableSize: Integer;
tmp: TBitmap;
LFrame: TGifFrameItem;
FrameIndex: Integer;
I: Integer;
LBC : integer;
LFrames : array of TGifFrameItem;
rendered : array of TBitmap;
begin
Result := False;
if not Check(Stream) then
Exit;
AFrameList.Clear;
FGifVer := verUnknow;
FPalette := nil;
LScanLineBuf := nil;
try
Stream.Position := 0;
Stream.Read(FHeader, SizeOf(FHeader));
{$IFDEF BIGENDIAN}
with FHeader do
begin
ScreenWidth := LEtoN(ScreenWidth);
ScreenHeight := LEtoN(ScreenHeight);
end;
{$ENDIF}
if (FHeader.Packedbit and $80) = $80 then
begin
ColorTableSize := FHeader.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
end;
if not ProcHeader then
Exit;
FrameIndex := 0;
SetLength(LFrames, 0);
while True do
begin
LLocalPalette := nil;
Repeat
Introducer := ReadAndProcBlock(Stream);
until (Introducer in [$2C, $3B]);
if Introducer = $3B then
Break;
Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
with FDescriptor do
begin
Left := LEtoN(Left);
Top := LEtoN(Top);
Width := LEtoN(Width);
Height := LEtoN(Height);
end;
{$ENDIF}
if (LDescriptor.Packedbit and $80) <> 0 then
begin
ColorTableSize := LDescriptor.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
end
else
begin
LLocalPalette := Copy(FPalette, 0, Length(FPalette));
end;
if not ProcFrame then
Exit;
LFrame := TGifFrameItem.Create;
LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime;
LFrame.FDisbitmap := TBitmap.Create(LFrameWidth, LFrameHeight);
LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top);
LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2);
if not ReadScanLine(Stream, #LScanLineBuf[0]) then
Exit;
if not WriteScanLine(LFrame.FDisbitmap, #LScanLineBuf[0]) then
Exit;
if LGraphCtrlExt then
begin
LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
If LIsTransparent then
LBC := LGraphicsCtrlExt.ColorIndex
else
LBC := FBackgroundColorIndex;
end
else
LBC := FBackgroundColorIndex;
LFrame.fBackColor := LLocalPalette[LBC].Color;
Inc(FrameIndex);
SetLength(LFrames, FrameIndex);
LFrames[FrameIndex - 1] := LFrame;
end;
SetLength(rendered, Length(LFrames));
for I := 0 to Length(LFrames) - 1 do
begin
tmp := TBitmap.Create(FScreenWidth, FScreenHeight);
RenderFrame(I, LFrames, tmp);
rendered[i] := tmp;
end;
for I := 0 to Length(LFrames) - 1 do
begin
LFrames[i].Bitmap.Assign(rendered[i]);
FreeAndNil(rendered[i]);
AFrameList.Add(LFrames[i]);
end;
Result := True;
finally
LLocalPalette := nil;
LScanLineBuf := nil;
rendered := nil;
LFrames := nil;
end;
end;
function TGifReader.Check(Stream: TStream): Boolean;
var
OldPos: Int64;
begin
try
OldPos := Stream.Position;
Stream.Read(FHeader, SizeOf(FHeader));
Result := (CompareMem(#FHeader.Signature, #GifSignature, 3)) and
(CompareMem(#FHeader.Version, #VerSignature87a, 3)) or
(CompareMem(#FHeader.Version, #VerSignature89a, 3));
Stream.Position := OldPos;
except
Result := False;
end;
end;
function TGifReader.Check(FileName: string): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Check(fs);
except
end;
fs.DisposeOf;
end;
constructor TGifReader.Create;
begin
inherited Create;
end;
destructor TGifReader.Destroy;
begin
inherited Destroy;
end;
{ TGifFrameItem }
destructor TGifFrameItem.Destroy;
begin
if FDisbitmap <> nil then
begin
FDisbitmap.DisposeOf;
FDisbitmap := nil;
end;
inherited Destroy;
end;
end.

Split up serial data in delphi

I am a newbie in Delphi programming and I need some help. I have a problem with spliting my serial data. This is my code:
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x, i: integer;
save_data : TStringList;
begin
save_data := TStringList.create;
for x := 0 to Count-1 do begin
ComPort1.ReadStr(DataByte,1);
if DataByte = 'n' then
begin
memo1.Text := '';
end
else
begin
memo1.Text := memo1.Text + DataByte;
Split(' ', DataByte, save_data);
end;
end;
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
save_data.Free;
end;
My Split(' ', DataByte, save_data); doesn't work. I don't understand because I just split String data which is taken from the serial port. This is my Split() procedure:
procedure TForm1.Split(const Delimiter: Char; Input: string; const Strings: TStrings) ;
begin
Assert(Assigned(Strings));
Strings.Clear;
Strings.Delimiter := Delimiter;
Strings.DelimitedText := Input;
end;
I do not know why my program is giving me a EStringListError error.
You are calling ReadStr() to read individual bytes, and calling Split() on every byte (except for 'n'). So the TStringList will only ever hold 1 string at a time. Like MBo said, you need to fix your loop to avoid that, eg:
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x: integer;
save_data : TStringList;
begin
ComPort1.ReadStr(DataByte, Count);
for x := 1 to Length(DataByte) do
begin
if DataByte[x] = 'n' then
begin
Memo1.Text := '';
end
else
begin
Memo1.Text := Memo1.Text + DataByte[x];
end;
end;
save_data := TStringList.create;
try
Split(' ', DataByte, save_data);
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
finally
save_data.Free;
end;
end;
That being said, you are not taking into account that the number of bytes you receive for any given OnRxChar event call is arbitrary. It is whatever raw bytes have been read at that exact moment. You are assuming a full string with at least 6 delimited substrings, and that is simply not guaranteed. You need to buffer the raw data as you receive it, and then parse and remove only completed strings from the buffer as needed.
Try something more like this:
var
DataBuffer: string;
// consider using the OnRxBuf event instead...
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x: integer;
save_data : TStringList;
begin
ComPort1.ReadStr(DataByte, Count);
DataBuffer := DataBuffer + DataByte;
x := Pos('n', DataBuffer);
if x = 0 then Exit;
save_data := TStringList.Create;
try
repeat
DataByte := Copy(DataBuffer, 1, x-1);
Delete(DataBuffer, 1, x);
Memo1.Text := DataByte;
Split(' ', DataByte, save_data);
if save_data.Count >= 6 then
begin
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
end;
x := Pos('n', DataBuffer);
until x = 0;
finally
save_data.Free;
end;
end;
if Comport is Dejan Crnila CPort class, then this line
ComPort1.ReadStr(DataByte,1);
replaces Databyte contents every time, and this string always is 1-byte length.
Just read all bytes from buffer with single call
ComPort1.ReadStr(DataByte, Count);
and do work with string

Load MultiFrame Icons

Does anyone know of a class that can read multiframe icons? Searching the internet has not produced any information.
I tried using IconTools 2.0 by Alan Peter Stotz, which loads the icons into a list correctly but the bit-depth for 8-bit and 4-bit icons return as 0. The bitdepth for 32 and 24-bit icon frames is returned correctly, however.
The icon itself appears correct when viewing... just the bitdepth is wrong for the bits mentioned.
EDIT #2
Baised on the comment by TLama here is some untested code:
function NumberOfIcons ( AFileName: string ): integer;
var
iNumberOfIcons: Integer;
begin
iNumberOfIcons := ExtractIcon ( hInstance, PChar ( AFilename ), UINT ( -1 ) );
Result := iNumberOfIcons;
end;
function ExtractAnIcon ( AFilename: string; AIndex: integer ): TBitmap;
var
icoHandle: HIcon;
iBitmap: TBitmap;
iIcon: TIcon;
iNumberOfIcons, i: Integer;
begin
Result := nil;
iBitmap := TBitMap.Create;
iIcon := TIcon.Create;
try
// Get the number of Icons
iNumberOfIcons := ExtractIcon ( hInstance, PChar ( AFilename ), UINT ( -1 ) );
// Extract the icon frame
icoHandle := ExtractIcon ( hInstance, PChar ( AFileName ), AIndex );
iIcon.Handle := icoHandle;
iBitmap.Width := iIcon.Width;
iBitmap.Height := iIcon.Height;
// Draw the icon on your bitmap
DrawIcon ( iBitmap.Canvas.Handle, 0, 0, iIcon.Handle );
Result := iBitmap;
finally
iIcon.Free;
end;
end;
function PixelFormatToBitDepth ( APixelFormat: TPixelFormat ): integer;
// Convert TPixelFormat to integer
begin
Result := -1;
case APixelFormat of
pf32Bit:
Result := 32;
pf24bit:
Result := 24;
pf8bit:
Result := 8;
pf4Bit:
Result := 4;
pf1bit:
Result := 1;
end;
end;
Am I on the right track? In my testing I now get 1 icon but the NumberOfIcons function is returning 1?
EDIT#3
According to the help file "If the file is an .ICO file, the return value of ExtractIcon is 1." So what method can be used to get the number of icons in the ico file?
Here is a small code example:
uses ShellApi;
type
TICONDIRENTRY = packed record
bWidth: Byte; // Width, in pixels, of the image
bHeight: Byte; // Height, in pixels, of the image
bColorCount: Byte; // Number of colors in image (0 if >=8bpp)
bReserved: Byte; // Reserved ( must be 0)
wPlanes: Word; // Color Planes
wBitCount: Word; // Bits per pixel
dwBytesInRes: DWORD; // How many bytes in this resource?
dwImageOffset: DWORD; // Where in the file is this image?
end;
TICONDIR = packed record
idReserved: Word; // Reserved (must be 0)
idType: Word; // Resource Type (1 for icons)
idCount: Word; // How many images?
idEntries: array [0..255] of TICONDIRENTRY;
end;
PICONDIR=^TICONDIR;
function GetIconsCount(const FileName: string): Word;
var
Stream: TMemoryStream;
IconDir: PICONDIR;
begin
Result := 0;
if ExtractIcon(hInstance, PChar(FileName), UINT(-1)) <> 0 then
try
Stream := TMemoryStream.Create;
try
Stream.LoadFromFile(FileName);
IconDir := Stream.Memory;
if IconDir.idType = 1 then
Result := IconDir.idCount;
finally
Stream.Free;
end;
except
// do not raise exceptions
end;
end;
function ExtractIcons(const FileName: string; IconList: TList): Boolean;
var
Stream: TMemoryStream;
NewIconStream: TMemoryStream;
IconDir: PICONDIR;
NewIconDir: PICONDIR;
Icon: TIcon;
I: Integer;
begin
Result := False;
if ExtractIcon(hInstance, PChar(FileName), UINT(-1)) <> 0 then
try
Stream := TMemoryStream.Create;
try
Stream.LoadFromFile(FileName);
IconDir := Stream.Memory;
for I := 0 to IconDir.idCount-1 do
begin
NewIconStream := TMemoryStream.Create;
try
NewIconStream.Size := SizeOf(Word) * 3 + SizeOf(TICONDIRENTRY);
NewIconStream.Position:= SizeOf(Word) * 3 + SizeOf(TICONDIRENTRY);
NewIconDir := NewIconStream.memory;
NewIconDir.idCount := 1;
NewIconDir.idType := IconDir.idType;
NewIconDir.idReserved := IconDir.idReserved;
NewIconDir.idEntries[0] := IconDir.idEntries[I];
NewIconDir.idEntries[0].dwImageOffset := NewIconStream.Size;
Stream.Position := IconDir.idEntries[I].dwImageOffset;
NewIconStream.CopyFrom(Stream, IconDir.idEntries[I].dwBytesInRes);
NewIconStream.Position := 0;
Icon := TIcon.Create;
Icon.LoadFromStream(NewIconStream);
IconList.Add(Icon);
finally
NewIconStream.Free;
end;
IconList.Add(Icon);
end;
Result := True;
finally
Stream.Free;
end;
except
// do not raise exceptions
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FileName: string;
Icon: TIcon;
List: TList;
I: Integer;
begin
FileName := 'c:\myicon.ico';
List := TList.Create;
try
if ExtractIcons(FileName, List) then
for I := 0 to List.Count - 1 do
begin
Icon := TIcon(List.Items[I]);
DrawIcon(Form1.Canvas.Handle, 10, I * 40, Icon.Handle);
Icon.Free;
end;
finally
List.Free;
end;
end;

How can I quickly convert an array of numeral characters into an integer?

Situation: a whole number saved as hex in a byte array(TBytes). Convert that number to type integer with less copying, if possible without any copying.
here's an example:
array = ($35, $36, $37);
This is '5', '6', '7' in ansi. How do I convert it to 567(=$273) with less trouble?
I did it by copying twice. Is it possible to be done faster? How?
You can use LookUp Table instead HexToInt...
This procedure works only with AnsiChars and of course no error checking is provided!
var
Table :array[byte]of byte;
procedure InitLookupTable;
var
n: integer;
begin
for n := 0 to Length(Table) do
case n of
ord('0')..ord('9'): Table[n] := n - ord('0');
ord('A')..ord('F'): Table[n] := n - ord('A') + 10;
ord('a')..ord('f'): Table[n] := n - ord('a') + 10;
else Table[n] := 0;
end;
end;
function HexToInt(var hex: TBytes): integer;
var
n: integer;
begin
result := 0;
for n := 0 to Length(hex) -1 do
result := result shl 4 + Table[ord(hex[n])];
end;
function BytesToInt(const bytes: TBytes): integer;
var
i: integer;
begin
result := 0;
for i := 0 to high(bytes) do
result := (result shl 4) + HexToInt(bytes[i]);
end;
As PA pointed out, this will overflow with enough digits, of course. The implementation of HexToInt is left as an exercise to the reader, as is error handling.
You can do
function CharArrToInteger(const Arr: TBytes): integer;
var
s: AnsiString;
begin
SetLength(s, length(Arr));
Move(Arr[0], s[1], length(s));
result := StrToInt(s);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37);
Caption := IntToStr(CharArrToInteger(a));
end;
If you know that the string is null-terminated, that is, if the final character in the array is 0, then you can just do
function CharArrToInteger(const Arr: TBytes): integer;
begin
result := StrToInt(PAnsiChar(#Arr[0]));
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37, 0);
Caption := IntToStr(CharArrToInteger(a));
end;
The most natural approach, however, is to use an array of characters instead of an array of bytes! Then the compiler can do some tricks for you:
procedure TForm1.FormCreate(Sender: TObject);
var
a: TCharArray;
begin
a := TCharArray.Create(#$35, #$36, #$37);
Caption := IntToStr(StrToInt(string(a)));
end;
It cannot be any faster than that ;-)
function HexToInt(num:pointer; size:Cardinal): UInt64;
var i: integer;
inp: Cardinal absolute num;
begin
if(size > SizeOf(Result)) then Exit;
result := 0;
for i := 0 to size-1 do begin
result := result shl 4;
case(PByte(inp+i)^) of
ord('0')..ord('9'): Inc(Result, PByte(inp+i)^ - ord('0'));
ord('A')..ord('F'): Inc(Result, PByte(inp+i)^ - ord('A') + 10);
ord('a')..ord('f'): Inc(Result, PByte(inp+i)^ - ord('a') + 10);
end;
end;
end;
function fHexToInt(b:TBytes): UInt64; inline;
begin
Result:=HexToInt(#b[0], Length(b));
end;
...
b:TBytes = ($35, $36, $37);
HexToInt(#b[0], 3);
fHexToInt(b);

Resources