pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
kolmck/Addons/KOLGif.pas

2849 lines
84 KiB
ObjectPascal
Raw Blame History

{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
KKKKK KKKKK OOOOOOOOO LLLLL
KKKKK KKKKK OOOOOOOOOOOOO LLLLL
KKKKK KKKKK OOOOO OOOOO LLLLL
KKKKK KKKKK OOOOO OOOOO LLLLL
KKKKKKKKKK OOOOO OOOOO LLLLL
KKKKK KKKKK OOOOO OOOOO LLLLL
KKKKK KKKKK OOOOO OOOOO LLLLL
KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL
KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL
Key Objects Library (C) 2000 by Kladov Vladimir.
K.O.L. - is a set of objects to create small programs
with Delphi, but without the VCL. It is based on the
idea of XCL, which also allows the creation of smaller
programs then in the VCL (about 5 times smaller).
However, this is not as small as the author (me) would
like. KOL allows the creation of applications about
10 times smaller then those created with the VCL. But
this does not mean that KOL is less power then the
VCL - perhaps just the opposite...
XCL and KOL are provided free with the source code.
Idea is copyrighted (C) to me, Vladimir Kladov.
The most of the code is also copyrighted (C) to me.
Code provided by other developers (even if later
changed by me) is fully aknowledged.
If You wish to take part in developing KOL, please
do let me know.
mailto: bonanzas@xcl.cjb.net
Home: http://kol.nm.ru
http://xcl.cjb.net
http://xcl.nm.ru
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
unit KOLGif;
{* This unit contains TGif and TGifDecoder object definitions, implementing
decoding and right painting of Graphic Interchange File format (gif-images).
Encoding is not implemented here.
|<br>&nbsp;&nbsp;&nbsp;
This code is ported from XCL code ( XGifs.pas ) with some enchancements.
|<br>&nbsp;&nbsp;&nbsp;
Originally, this code was extracted from freeware RXLib Delphi VCL
components library (rxgif.pas). VCL bloats and unneeded dependances
from other parts of RXLib were removed, and important add
was made: exact transparency mask, which helps to correctly
decode and paint ANY gif independantly from current video
settings.
|<br>&nbsp;&nbsp;&nbsp;
To get know about authors of RXLib, please visit
|<a href="http://www.rxlib.com">their site</a>.
|<br>&nbsp;&nbsp;&nbsp;
Rxgif code, was originally based on source of freeware GBM
program (C++) by
|<a href="mailto:nyangau@interalpha.co.uk">
Andy Key (nyangau@interalpha.co.uk)
|</a>.
}
//{$DEFINE CHK_BITBLT}
interface
{$I KOLDEF.INC}
{$IFDEF _D6orHigher}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
uses windows, KOL {, ChkGdi};
type
TGifVersion = ( gvUnknown, gv87a, gv89a );
TGifBits = 1..8;
TDisposeMethod = ( dmUndefined, dmLeave, dmRestoreBackground,
dmRestorePrevious );
TGifColorItem = record
Red: Byte;
Green:Byte;
Blue: Byte;
end;
TGifColorTable = record
ColorCount : Integer;
Colors : packed array[ Byte ] of TGifColorItem;
end;
PGifFrame = ^TGifFrame;
//PGifItem = ^TGifItem;
TGifItem = packed record // object( TObj )
//private
FImageData : PStream; // memory stream
FSize : TPoint;
FPackedFields : Byte;
FBitsPerPixel : Byte;
FColorMap : TGifColorTable;
{public
destructor Destroy; virtual;}
end;
//PGifData = ^TGifData;
TGifData = packed record // object( TObj )
//private
DComment : PStrList;
DAspectRatio : Byte;
DBitsPerPixel : Byte;
DColorResBits : Byte;
DColorMap : TGifColorTable;
{public
constructor Create;
destructor Destroy; virtual;}
end;
PGifDecoder = ^TGifDecoder;
TGifDecoder = object( TObj )
{* This object can be used directly to load gif image from file or stream
and to decode its frames. To provide correct drawing of animated gif
images, use TGif object, which is much more power, and works correctly
in the most cases. Therefore, TGifDecoder allows to decode single-frame
images easy and can be used to pack bitmap resources delivered together
with the application. }
private
FGifData : TGifData;
FVersion : TGifVersion;
FItems : PList; // of PGifFrame
FFrameIndex : Integer;
FGifWidth : Integer;
FGifHeight : Integer;
FBkColor : TColor;
FBackIndex : Integer;
FLooping : Boolean;
FRepeatCount : Word;
FNeedMask: Boolean;
FTransparent : Boolean;
FCorrupted: Boolean;
FOnNeedMask: procedure( Sender: PObj; var BIH: TBitmapInfoHeader; Bits: Pointer );
procedure NewImage;
procedure ClearItems;
function GetFrames(Idx: Integer): PGifFrame;
function GetComment: PStrList;
function GetBitmap: PBitmap;
procedure SetNeedMask(const Value: Boolean);
function GetMask: PBitmap;
protected
function GetWidth : Integer;
function GetHeight: Integer;
function GetFrameCount : Integer;
function GetFrame : Integer;
procedure SetFrame( Value : Integer );
public
destructor Destroy; virtual;
{* Use Free method instead. }
procedure Clear;
{* Clears gif image. }
property Count : Integer read GetFrameCount;
{* Returns count of frames stored in the gif image. }
property Frame : Integer read GetFrame write SetFrame;
{* Index of current frame (between 0 and Count-1). }
property Width : Integer read GetWidth;
{* Width of entire gif image. }
property Height : Integer read GetHeight;
{* Height of entire gif image. }
property BkColor : TColor read FBkColor write FBkColor;
{* Background color. After loading gif, this property contains a value,
which is used as a background (e.g. transparent) color of the entire
set of frames. For non-transparent images, this value is set to
clNone after loading the image. It is possible to change this value,
but this will affect only the Draw method (if TGifDecoder object is
used in TGif container). DrawTransp and DrawTransparent methods (of
TGif, too) use BkColor only for non-transparent images, and in case when
NeedMask is reset to False. }
property Looping: Boolean read FLooping write FLooping;
{* True, if loaded image is marked (by its authors) as "looping". }
property RepeatCount : Word read FRepeatCount write FRepeatCount;
{* Repeat count set by the author of gif image. }
property NeedMask : Boolean read FNeedMask write SetNeedMask;
{* This value is False by default for TGifDecoder instances used stanalone,
but it is set to True, when TGif is using the owned TGifDecoder object.
True requires a bit larger code to implement really truth transparency,
which independs from display resolution and color depth, and works
correctly even in case when background color of the first frame matches
non-transparent colors of other ones. }
property Transparent : Boolean read FTransparent;
{* True, if loaded gif image is transparent. }
property Version : TGifVersion read FVersion;
{* Version of gif. }
property Frames[ Idx : Integer ] : PGifFrame read GetFrames;
{* Acess frames as an array of pointers to TGifFrame object instances,
created while gif image is loading. }
property Comment : PStrList read GetComment;
{* Text comment, provided with gif image. }
function LoadFromStream( Stream : PStream ) : Boolean;
{* Call this method to load gif image from a stream and decode it. After
loading, first frame is decoded and ready to be drawn immediately. All
other frames are decoded when requested first time. Since this, a property
Corrupted can be not set to True just after loading the image and decoding
several first frames, and can become True later, when requested frame
found corrupted while decoding it. }
function LoadFromFile( const FileName : String ) : Boolean;
{* Call this method to load gif image from the file and decode it. See
also LoadFromStream - the most told there is true here too. }
function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean;
{* Call this method to load GIF image from resource by its name.
GIF image must be stored in RCDATA resource named using unique
ANSI string. }
function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
{* Call this method to load GIF from resource (RCDATA) by ID. }
property Bitmap : PBitmap read GetBitmap;
{* Current frame bitmap. }
property Mask: PBitmap read GetMask;
{* Current frame truth mask. }
procedure FreeResources;
{* Call this method to free the most of GDI resources allocated while
decoding the image. This forces using DIB bitmaps without handles
(see TBitmap.Dormant), releases Canvas, Brush objects etc. }
property Corrupted: Boolean read FCorrupted;
{* True, if the image found corrupted while decoding. Note, that just after
loading the image and after decoding several first frames, this property
can be yet not set even for bad gifs. It becomes True for such gif images
when a frame requested is corrupted. }
end;
TGifFrame = object( TObj )
{* Object to manipulate with certain frame data of TGIF object. }
private
FOwner : PGifDecoder;
FBitmap : PBitmap;
FItem : TGifItem;
FExtensions : PList;
FTopLeft : TPoint;
FInterlaced : Boolean;
FCorrupted : Boolean;
FTranspColor : TColor;
FDelay : Word;
FLocalColors : Boolean;
FTransparent : Boolean;
FTransIndex : Integer;
FTransMask : PBitmap;
FFrameIndex : Integer;
FReallyTransparent : Boolean;
FDisposalMethod: TDisposeMethod;
procedure SetDelay(const Value: Word);
function GetColorCount: Integer;
function FindComment(ForceCreate: Boolean): PStrList;
function GetComment: PStrList;
procedure SetComment(const Value: PStrList);
procedure SetDisposalMethod(const Value: TDisposeMethod);
procedure SetTranspColor(const Value: TColor);
procedure SetTopLeft(const Value: TPoint);
function GetHeight: Integer;
function GetWidth: Integer;
function GetReallyTransparent: Boolean;
function GetBitmap: PBitmap;
procedure New_Bitmap;
protected
//constructor Create( AOwner : PGifDecoder );
function LoadFromStream( Stream : PStream ) : Boolean;
public
destructor Destroy; virtual;
{* Do not destroy frames manually. The owner of frames (TGifDecoder) is
responsible for freeing its frames. }
property Bitmap : PBitmap read GetBitmap;
{* Frame bitmap. This can be only a small rectangle in bounds of
entire GIF image. If You do not know how to combine frame
bitmaps to produce GIF animation, use TGIF drawing methods
to perform this task. }
property Mask : PBitmap read FTransMask;
{* Exact monochrome mask of transparency. Used in ZGIF drawing
to produce correct showing of any GIF image independently
from display resolution. }
property Delay : Word read FDelay write SetDelay;
{* Frame delay (delay of frame exposure). }
property ColorCount : Integer read GetColorCount;
{* Number of colors. }
property Comment: PStrList read GetComment write SetComment;
{* Comment to frame. }
property DisposalMethod : TDisposeMethod read FDisposalMethod write SetDisposalMethod;
{* Disposal method. This is the most hard part for recognition
how to animate certain GIF image. It seems that it is implemented
in TGIF well, at least, it was tested for about 200 different
GIF clips, and no errors were found. }
property Interlaced: Boolean read FInterlaced;
{* True, if interlaced. }
property Corrupted: Boolean read FCorrupted;
{* True, if corrupted. }
property TranspColor : TColor read FTranspColor write SetTranspColor;
{* Transparent color. }
property Origin: TPoint read FTopLeft write SetTopLeft;
{* Offset of a frame from top left corner of GIF image. }
property Width: Integer read GetWidth;
{* Width of frame. }
property Height: Integer read GetHeight;
{* Height of frame. }
property Transparent : Boolean read FTransparent;
{* True, if frame is transparent. }
property TransColorIndex : Integer read fTransIndex;
{* Exact index of transparent color in frame's palette. }
property ReallyTransparent : Boolean read GetReallyTransparent;
{* True, if frame is "really" transparent (i.e. its transparent
color is used in frame at least for one pixel). }
procedure FreeResources;
{* }
procedure Draw( DC : HDC; X, Y : Integer );
{* }
procedure StretchDraw( DC : HDC; Rect : TRect );
{* }
end;
/////////////////////////////////////////////////////////////
PGif = ^TGif;
TGif = object( TObj )
{* GIF decoding and painting object. This object represents almost full
decoder, which yet not a control but already sufficiently "clever"
to treat "frame" as a result of all previous frame commands. I.e.
You do not need to combine frames by yourself to provide animation.
Just change current frame index (usually increase) and call one of
drawing methods to paint the desired frame. }
private
FGifImage : PGifDecoder;
FCurFrame : PBitmap;
FCurMask : PBitmap;
FCurIndex : Integer;
FPrevFrame : PBitmap;
FPrevMask : PBitmap;
procedure PrepareFrame;
function GetBkColor: TColor;
procedure SetBkColor(const Value: TColor);
function GetFrames(Idx: Integer): PGifFrame;
function GetTransparent: Boolean;
function GetCorrupted: Boolean;
protected
FOnChanged: TOnEvent;
function GetWidth : Integer;
procedure SetWidth( Value : Integer );
function GetHeight : Integer;
procedure SetHeight( Value : Integer );
function GetFrame : Integer;
procedure SetFrame( Value : Integer );
function GetFrameCount : Integer;
function GetDelays( Idx : Integer ) : Integer;
procedure SetDelays( Idx : Integer; Value : Integer );
procedure Changed;
public
destructor Destroy; virtual;
{* Destructor. }
procedure Clear;
{* Obvious. }
property Width: Integer read GetWidth write SetWidth;
{* Width of total GIF image. }
property Height: Integer read GetHeight write SetHeight;
{* Height of total GIF image. }
procedure FreeResources;
{* Call this method to free GDI resources, allocated for decoding gif image,
and to drawing it. This does not destroy any image information or data
already obtained from encoded frames. It is possible to call this method
after drawing every other frame, but this can slow down drawing process
a bit. }
procedure Draw( DC : HDC; X, Y : Integer );
{* Draws current frame. }
procedure DrawTransp( DC: HDC; X, Y: Integer );
{* Draws current frame transparently, using its native TranspColor as
transparent color if any. If the frame is not transparent, it is
drawing non-transparently. }
procedure DrawTransparent( DC : HDC; X, Y : Integer; TranspColor : TColor );
{* Draws current frame transparently. }
// By Dufa
procedure DrawTransparentEx(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer);
// Draw Tranparent Frame
procedure StretchDraw( DC : HDC; const Dest : TRect ); //override;
{* Draws current frame with stretching. }
procedure StretchDrawTransp( DC: HDC; const Dest: TRect );
{* Draws current frame stretched and transparently using BkColor as a
transparent color or using Mask if available. }
procedure StretchDrawTransparent( DC : HDC; const Dest : TRect; TranspColor : TColor );
{* Draws current frame with strethcing transparently. }
property BkColor : TColor read GetBkColor write SetBkColor;
{* Background color. }
property Frames[ Idx : Integer ] : PGifFrame read GetFrames;
{* Array of frame data. }
property Transparent : Boolean read GetTransparent;
{* True, if GIF is transparent (i.e. at least one of frames is transparent). }
function LoadFromStream( Stream : PStream ) : Boolean;
{* Loads GIF from a stream. }
function LoadFromFile( const FileName : String ) : Boolean;
{* Loads GIF from a file. }
function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean;
{* Call this method to load GIF image from resource by its name.
GIF image must be stored in RCDATA resource named using unique
ANSI string. }
function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
{* Call this method to load GIF from resource (RCDATA) by ID. }
property Count: Integer read GetFrameCount;
{* Number of frames in a gif. }
property Frame: Integer read GetFrame write SetFrame;
{* Index of current frame. }
property Delay[ Idx: Integer ]: Integer read GetDelays write SetDelays;
{* Delay for every frame. }
property Corrupted: Boolean read GetCorrupted;
{* True if any of frames decoded is corrupted or could not be decoded. }
end;
function NewGif: PGif;
{* Call this function to create fully featured gif decoding and painting object.
This adds about 30K code to the executable. }
function NewGifNoMask: PGif;
{* Call this method to create gif decoding object, which does not support for
truth mask (some animated and / or transparent images are drawn incorrectly,
but code used is smaller a bit). Actually, this economies only about 1K of code. }
function NewGifDecoder: PGifDecoder;
{* Call this method to create simple gif reading object, which just decodes
separate frames. If only this type of objects is used, smaller portion of
code is included into final executeable. Actually, this economies about 5-6K
of executable size. }
procedure DrawBitmapMaskMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap );
procedure DrawBitmapMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap );
type
PGifShow = ^TGifShow;
TGifShow = object( TControl )
private
function GetDummy: Boolean;
protected
function GetAnimate: Boolean;
function GetGif: PGif;
procedure SetAnimate(const Value: Boolean);
function GetLoop: Boolean;
function GetOnEndLoop: TOnEvent;
procedure SetLoop(const Value: Boolean);
procedure SetOnEndLoop(const Value: TOnEvent);
function GetAutosize: Boolean;
function GetStretch: Boolean;
procedure SetAutosize(const Value: Boolean);
procedure SetStretch(const Value: Boolean);
protected
procedure GifChanged( Sender: PObj );
procedure NextFrame( Sender: PObj );
procedure PaintFrame( Sender: PControl; DC: HDC );
public
{$WARNINGS OFF}
property Autosize: Boolean read GetAutosize write SetAutosize;
{$WARNINGS ON}
property Stretch: Boolean read GetStretch write SetStretch;
property Animate: Boolean read GetAnimate write SetAnimate;
property Loop: Boolean read GetLoop write SetLoop;
//property Dormant: Boolean read GetDormant write SetDormant;
property Gif: PGif read GetGif;
property OnEndLoop: TOnEvent read GetOnEndLoop write SetOnEndLoop;
property OnPaint: Boolean read GetDummy;
function LoadFromStream( Stream : PStream ) : Boolean;
{* Call this method to load gif image from a stream and decode it. After
loading, first frame is decoded and ready to be drawn immediately. All
other frames are decoded when requested first time. Since this, a property
Corrupted can be not set to True just after loading the image and decoding
several first frames, and can become True later, when requested frame
found corrupted while decoding it. }
function LoadFromFile( const FileName : String ) : Boolean;
{* Call this method to load gif image from the file and decode it. See
also LoadFromStream - the most told there is true here too. }
function LoadFromResourceName( Inst: HInst; RsrcName: PChar ): Boolean;
{* Call this method to load GIF image from resource by its name.
GIF image must be stored in RCDATA resource named using unique
ANSI string. }
function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
{* Call this method to load GIF from resource (RCDATA) by ID. }
end;
function NewGifShow( AParent: PControl ): PGifShow;
type TKOLGifShow = PGifShow;
implementation
const
ROP_DstAndNotSrc = $00220326;
function NewGifFrame( AOwner: PGifDecoder ): PGifFrame; forward;
procedure DrawBitmapMaskMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap );
begin
if Msk = nil then
Bmp.Draw( DC, X, Y )
else
//if Bmp.HandleAllocated then
begin
BitBlt( DC, X, Y, Bmp.Width, Bmp.Height, Msk.Canvas.Handle,
0, 0, SrcAnd );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
BitBlt( DC, X, Y, Bmp.Width, Bmp.Height,
Bmp.Canvas.Handle, 0, 0, SRCPAINT );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
end;
end;
procedure DrawBitmapMask( DC : HDC; X, Y : Integer; Bmp, Msk : PBitmap );
var TmpBmp : PBitmap;
begin
if Msk = nil then
Bmp.Draw( DC, X, Y )
else
//if Bmp.HandleAllocated then
begin
TmpBmp := NewBitmap( 0, 0 );
TmpBmp.Assign( Bmp );
BitBlt( TmpBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
DrawBitmapMaskMask( DC, X, Y, TmpBmp, Msk );
//TmpBmp.SaveToFile( GetStartDir + 'DrawBitmapMask.TmpBmp.bmp' );
//Msk.SaveToFile( GetStartDir + 'DrawBitmapMask.Msk.bmp' );
TmpBmp.Free;
end;
end;
procedure StretchBitmapMaskMask( DC : HDC; Rect : TRect; Bmp, Msk : PBitmap );
var OldMode: Integer;
OldOrgX: TPoint;
begin
OldMode := SetStretchBltMode( DC, HALFTONE );
SetBrushOrgEx( DC, 0, 0, @ OldOrgX );
if Msk = nil then
Bmp.StretchDraw( DC, Rect )
else
//if Bmp.HandleAllocated then
begin
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
Msk.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, SrcAnd );
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, SRCPAINT );
end;
SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil );
SetStretchBltMode( DC, OldMode );
end;
procedure StretchBitmapMask( DC : HDC; Rect : TRect; Bmp, Msk : PBitmap );
var TmpBmp : PBitmap;
OldMode: Integer;
OldOrgX: TPoint;
begin
OldMode := SetStretchBltMode( DC, HALFTONE );
SetBrushOrgEx( DC, 0, 0, @ OldOrgX );
if Msk = nil then
Bmp.StretchDraw( DC, Rect )
else
//if Bmp.HandleAllocated then
begin
//TmpBmp := NewDIBBitmap( 0, 0, Bmp.PixelFormat );
TmpBmp := NewBitmap( 0, 0 );
TmpBmp.Assign( Bmp );
BitBlt( TmpBmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
StretchBitmapMaskMask( DC, Rect, TmpBmp, Msk );
TmpBmp.Free;
end;
SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil );
SetStretchBltMode( DC, OldMode );
end;
{function HugeOffset(HugePtr: Pointer; Amount: Longint): Pointer;
begin
Result := PChar(HugePtr) + Amount;
end;}
function AllocMemo(Size: Longint): Pointer;
begin
if Size > 0 then
Result := GlobalAllocPtr(HeapAllocFlags or GMEM_ZEROINIT, Size)
else Result := nil;
end;
procedure FreeMemo(var fpBlock: Pointer);
begin
if fpBlock <> nil then begin
GlobalFreePtr(fpBlock);
fpBlock := nil;
end;
end;
const
GIFSignature = 'GIF';
GIFVersionStr: array[TGIFVersion] of PChar = (#0#0#0, '87a', '89a');
const
CODE_TABLE_SIZE = 4096;
HASH_TABLE_SIZE = 17777;
MAX_LOOP_COUNT = 30000;
CHR_EXT_INTRODUCER = '!';
CHR_IMAGE_SEPARATOR = ',';
CHR_TRAILER = ';'; { indicates the end of the GIF Data stream }
{ Image descriptor bit masks }
ID_LOCAL_COLOR_TABLE = $80; { set if a local color table follows }
ID_INTERLACED = $40; { set if image is interlaced }
ID_SORT = $20; { set if color table is sorted }
ID_RESERVED = $0C; { reserved - must be set to $00 }
ID_COLOR_TABLE_SIZE = $07; { Size of color table as above }
{ Logical screen descriptor packed field masks }
LSD_GLOBAL_COLOR_TABLE = $80; { set if global color table follows L.S.D. }
LSD_COLOR_RESOLUTION = $70; { Color resolution - 3 bits }
LSD_SORT = $08; { set if global color table is sorted - 1 bit }
LSD_COLOR_TABLE_SIZE = $07; { Size of global color table - 3 bits }
{ Actual Size = 2^value+1 - value is 3 bits }
{ Graphic control extension packed field masks }
GCE_TRANSPARENT = $01; { whether a transparency Index is given }
GCE_USER_INPUT = $02; { whether or not user input is expected }
GCE_DISPOSAL_METHOD = $1C; { the way in which the graphic is to be treated after being displayed }
GCE_RESERVED = $E0; { reserved - must be set to $00 }
{ Application extension }
AE_LOOPING = $01; { looping Netscape extension }
GIFColors: array[TGIFBits] of Word = (2, 4, 8, 16, 32, 64, 128, 256);
function ColorsToBits(ColorCount: Word): Byte;
var
I: TGIFBits;
begin
for I := Low(TGIFBits) to High(TGIFBits) do
if ColorCount = GIFColors[I] then
begin
Result := I;
Exit;
end;
Result := 0;
end;
{function ColorsToPixelFormat(Colors: Word): TPixelFormat;
begin
//if Colors <= 2 then Result := pf1bit
//else if Colors <= 16 then Result := pf4bit
//else if Colors <= 256 then Result := pf8bit
//else Result := pf24bit;
//else
Result := pf16bit; //&&&
end;}
function ItemToRGB(const Item: TGIFColorItem): Longint;
begin
with Item do
Result := RGB(Red, Green, Blue);
end;
{ The following types and function declarations are used to call into
functions of the GIF implementation of the GIF image
compression/decompression standard. }
type
TGIFHeader = packed record
Signature: array[0..2] of Char; { contains 'GIF' }
Version: array[0..2] of Char; { '87a' or '89a' }
end;
TScreenDescriptor = packed record
ScreenWidth: Word; { logical screen width }
ScreenHeight: Word; { logical screen height }
PackedFields: Byte;
BackgroundColorIndex: Byte; { Index to global color table }
AspectRatio: Byte; { actual ratio = (AspectRatio + 15) / 64 }
end;
TImageDescriptor = packed record
ImageLeftPos: Word; { column in pixels in respect to left of logical screen }
ImageTopPos: Word; { row in pixels in respect to top of logical screen }
ImageWidth: Word; { width of image in pixels }
ImageHeight: Word; { height of image in pixels }
PackedFields: Byte;
end;
{ GIF Extensions support }
type
TExtensionType = (etGraphic, etPlainText, etApplication, etComment);
const
ExtLabels: array[TExtensionType] of Byte = ($F9, $01, $FF, $FE);
LoopExt: string[11] = 'NETSCAPE2.0';
type
TGraphicControlExtension = packed record
BlockSize: Byte; { should be 4 }
PackedFields: Byte;
DelayTime: Word; { in centiseconds }
TransparentColorIndex: Byte;
Terminator: Byte;
end;
TPlainTextExtension = packed record
BlockSize: Byte; { should be 12 }
Left, Top, Width, Height: Word;
CellWidth, CellHeight: Byte;
FGColorIndex, BGColorIndex: Byte;
end;
TAppExtension = packed record
BlockSize: Byte; { should be 11 }
AppId: array[1..8] of Byte;
Authentication: array[1..3] of Byte;
end;
TExtensionRecord = packed record
case ExtensionType: TExtensionType of
etGraphic: (GCE: TGraphicControlExtension);
etPlainText: (PTE: TPlainTextExtension);
etApplication: (APPE: TAppExtension);
end;
type
PExtension = ^TExtension;
TExtension = object( TObj )
private
FExtType: TExtensionType;
FList: PStrList;
FExtRec: TExtensionRecord;
public
function IsLoopExtension: Boolean;
destructor Destroy; virtual;
end;
destructor TExtension.Destroy;
begin
FList.Free;
inherited;
end;
function TExtension.IsLoopExtension: Boolean;
begin
Result := (FExtType = etApplication) and CompareMem(@FExtRec.APPE.AppId,
@LoopExt[1], FExtRec.APPE.BlockSize) and (FList.Count > 0) and
(Length(FList.Items[0]) >= 3) and (Byte(FList.Items[0][1]) = AE_LOOPING);
end;
function FindExtension(Extensions: PList; ExtType: TExtensionType): PExtension;
var
I: Integer;
begin
if Extensions <> nil then
for I := Extensions.Count - 1 downto 0 do begin
Result := PExtension(Extensions.Items[I]);
if (Result <> nil) and (Result.FExtType = ExtType) then Exit;
end;
Result := nil;
end;
procedure FreeExtensions(Extensions: PList);
begin
if Extensions <> nil then
begin
while Extensions.Count > 0 do
begin
PObj(Extensions.Items[Extensions.Count - 1]).Free;
Extensions.Delete(Extensions.Count - 1);
end;
Extensions.Free;
end;
end;
{ GIF read procedures
Procedures to read and write GIF files, GIF-decoding and encoding
based on freeware C source code of GBM package by Andy Key
(nyangau@interalpha.co.uk). The home page of GBM author is
at http://www.interalpha.net/customer/nyangau/. }
type
PIntCodeTable = ^TIntCodeTable;
TIntCodeTable = array[0..CODE_TABLE_SIZE - 1] of Word;
PReadContext = ^TReadContext;
TReadContext = record
Inx, Size: Longint;
Buf: array[0..255 + 4] of Byte;
CodeSize: Longint;
ReadMask: Longint;
end;
TOutputContext = record
W, H, X, Y: Longint;
BitsPerPixel, Pass: Integer;
Interlace: Boolean;
LineIdent: Longint;
Data, CurrLineData: Pointer;
end;
PImageDict = ^TImageDict;
TImageDict = record
Tail, Index: Word;
Col: Byte;
end;
PDictTable = ^TDictTable;
TDictTable = array[0..CODE_TABLE_SIZE - 1] of TImageDict;
PRGBPalette = ^TRGBPalette;
TRGBPalette = array [Byte] of TRGBQuad;
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
begin
Result := Y;
case Pass of
0, 1: Inc(Result, 8);
2: Inc(Result, 4);
3: Inc(Result, 2);
end;
if Result >= Height then begin
if Pass = 0 then begin
Pass := 1; Result := 4;
if (Result < Height) then Exit;
end;
if Pass = 1 then begin
Pass := 2; Result := 2;
if (Result < Height) then Exit;
end;
if Pass = 2 then begin
Pass := 3; Result := 1;
end;
end;
end;
procedure ReadImageStream(Stream : PStream; Dest: PStream; var Desc: TImageDescriptor;
var Interlaced, LocalColors, Corrupted: Boolean; var BitsPerPixel: Byte;
var ColorTable: TGIFColorTable);
const BufSize = 1024;
var
CodeSize, BlockSize: Byte;
procedure ProvideDestSize( Size : DWord );
begin
if Dest.Size < Size then
Dest.Size := Size;
end;
begin
Corrupted := False;
Stream.Read(Desc, SizeOf(TImageDescriptor));
Interlaced := (Desc.PackedFields and ID_INTERLACED) <> 0;
if (Desc.PackedFields and ID_LOCAL_COLOR_TABLE) <> 0 then
begin
{ Local colors table follows }
BitsPerPixel := 1 + Desc.PackedFields and ID_COLOR_TABLE_SIZE;
LocalColors := True;
ColorTable.ColorCount := 1 shl BitsPerPixel;
Stream.Read(ColorTable.Colors[0],
ColorTable.ColorCount * SizeOf(TGIFColorItem));
end
else
begin
LocalColors := False;
FillChar(ColorTable, SizeOf(ColorTable), 0);
end;
Stream.Read(CodeSize, 1);
ProvideDestSize( BufSize );
Dest.Write(CodeSize, 1);
repeat
Stream.Read(BlockSize, 1);
if (Stream.Position + BlockSize) > Stream.Size then
begin
Corrupted := True;
Exit; {!!?}
end;
ProvideDestSize( ((Dest.Size + 1 + BlockSize + BufSize - 1) div BufSize) * BufSize );
Dest.Write(BlockSize, 1);
if (Stream.Position + BlockSize) > Stream.Size then
begin
BlockSize := Stream.Size - Stream.Position;
Corrupted := True;
end;
if BlockSize > 0 then
Stream2Stream( Dest, Stream, BlockSize );
until (BlockSize = 0) or (Stream.Position >= Stream.Size);
end;
procedure FillRGBPalette(const ColorTable: TGIFColorTable;
var Colors: TRGBPalette);
var
I: Byte;
begin
FillChar(Colors, SizeOf(Colors), $80);
for I := 0 to ColorTable.ColorCount - 1 do begin
Colors[I].rgbRed := ColorTable.Colors[I].Red;
Colors[I].rgbGreen := ColorTable.Colors[I].Green;
Colors[I].rgbBlue := ColorTable.Colors[I].Blue;
Colors[I].rgbReserved := 0;
end;
end;
function ReadCode(Stream: PStream; var Context: TReadContext): Longint;
var
RawCode: Longint;
ByteIndex: Longint;
Bytes: Byte;
BytesToLose: Longint;
begin
while (Context.Inx + Context.CodeSize > Context.Size) and
(Stream.Position < Stream.Size) do
begin
{ not enough bits in buffer - refill it }
{ Not very efficient, but infrequently called }
BytesToLose := Context.Inx shr 3;
{ Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes }
Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
Context.Inx := Context.Inx and 7;
Context.Size := Context.Size - (BytesToLose shl 3);
Stream.Read(Bytes, 1);
if Bytes > 0 then
Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
Context.Size := Context.Size + (Bytes shl 3);
end;
ByteIndex := Context.Inx shr 3;
RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then
RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask;
end;
procedure Output(Value: Byte; var Context: TOutputContext);
var
P: PByte;
begin
if (Context.Y >= Context.H) then Exit;
case Context.BitsPerPixel of
1: begin
//P := HugeOffset(Context.CurrLineData, Context.X shr 3);
P := Pointer( Integer( Context.CurrLineData ) + Context.X shr 3 );
if (Context.X and $07 <> 0) then
P^ := P^ or Word(value shl (7 - (Word(Context.X and 7))))
else P^ := Byte(value shl 7);
end;
4: begin
//P := HugeOffset(Context.CurrLineData, Context.X shr 1);
P := Pointer( Integer( Context.CurrLineData ) + Context.X shr 1 );
if (Context.X and 1 <> 0) then P^ := P^ or Value
else P^ := Byte(value shl 4);
end;
8: begin
//P := HugeOffset(Context.CurrLineData, Context.X);
P := Pointer( Integer( Context.CurrLineData ) + Context.X );
P^ := Value;
end;
end;
Inc(Context.X);
if Context.X < Context.W then Exit;
Context.X := 0;
if Context.Interlace then
Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
else Inc(Context.Y);
Context.CurrLineData := //HugeOffset(Context.Data,
//(Context.H - 1 - Context.Y) * Context.LineIdent);
Pointer( Integer( Context.Data ) + (Context.H - 1 - Context.Y) * Context.LineIdent );
end;
procedure ReadGIFData(Stream: PStream; const Header: TBitmapInfoHeader;
Interlaced: Boolean; IntBitPerPixel: Byte; Data: Pointer;
var Corrupted: Boolean);
var
MinCodeSize: Byte;
MaxCode, BitMask, InitCodeSize: Longint;
ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
I, OutCount, Code: Longint;
CurCode, OldCode, InCode, FinalChar: Word;
Prefix, Suffix, OutCode: PIntCodeTable;
ReadCtxt: TReadContext;
OutCtxt: TOutputContext;
TableFull: Boolean;
begin
Corrupted := False;
OutCount := 0; OldCode := 0; FinalChar := 0;
TableFull := False;
Prefix := AllocMem(SizeOf(TIntCodeTable));
//try
Suffix := AllocMem(SizeOf(TIntCodeTable));
//try
OutCode := AllocMem(SizeOf(TIntCodeTable) + SizeOf(Word));
//try
//try
Stream.Read(MinCodeSize, 1);
if (MinCodeSize < 2) or (MinCodeSize > 9) then
begin
//GifError( 'Bad GIF Code Size' );
Corrupted := True;
Exit;
end;
{ Initial read context }
ReadCtxt.Inx := 0;
ReadCtxt.Size := 0;
ReadCtxt.CodeSize := MinCodeSize + 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
{ Initialise pixel-output context }
OutCtxt.X := 0; OutCtxt.Y := 0;
OutCtxt.Pass := 0;
OutCtxt.W := Header.biWidth;
OutCtxt.H := Header.biHeight;
OutCtxt.BitsPerPixel := Header.biBitCount;
OutCtxt.Interlace := Interlaced;
OutCtxt.LineIdent := ((Header.biWidth * Header.biBitCount + 31)
div 32) * 4;
OutCtxt.Data := Data;
//OutCtxt.CurrLineData := HugeOffset(Data, (Header.biHeight - 1) *
// OutCtxt.LineIdent);
OutCtxt.CurrLineData := Pointer( Integer( Data ) + (Header.biHeight - 1) *
OutCtxt.LineIdent );
BitMask := (1 shl IntBitPerPixel) - 1;
{ 2 ^ MinCodeSize accounts for all colours in file }
ClearCode := 1 shl MinCodeSize;
EndingCode := ClearCode + 1;
FreeCode := ClearCode + 2;
FirstFreeCode := FreeCode;
{ 2^ (MinCodeSize + 1) includes clear and eoi Code and space too }
InitCodeSize := ReadCtxt.CodeSize;
MaxCode := 1 shl ReadCtxt.CodeSize;
Code := ReadCode(Stream, ReadCtxt);
while (Code <> EndingCode) and (Code <> $FFFF) and
(OutCtxt.Y < OutCtxt.H) do
begin
if (Code = ClearCode) then begin
ReadCtxt.CodeSize := InitCodeSize;
MaxCode := 1 shl ReadCtxt.CodeSize;
ReadCtxt.ReadMask := MaxCode - 1;
FreeCode := FirstFreeCode;
Code := ReadCode(Stream, ReadCtxt);
CurCode := Code; OldCode := Code;
if (Code = $FFFF) then Break;
FinalChar := (CurCode and BitMask);
Output(Byte(FinalChar), OutCtxt);
TableFull := False;
end
else
begin
CurCode := Code;
InCode := Code;
if CurCode >= FreeCode then begin
CurCode := OldCode;
OutCode^[OutCount] := FinalChar;
Inc(OutCount);
end;
while (CurCode > BitMask) do
begin
if (OutCount > CODE_TABLE_SIZE) then
begin
//if LoadCorrupt then
//begin
CurCode := BitMask;
OutCount := 1;
Corrupted := True;
Break;
{end
else //GifError( 'GIF Decode Error' );
begin
Corrupted := True;
Break;
end;}
end;
OutCode^[OutCount] := Suffix^[CurCode];
Inc(OutCount);
CurCode := Prefix^[CurCode];
end;
if Corrupted then Break;
FinalChar := CurCode and BitMask;
OutCode^[OutCount] := FinalChar;
Inc(OutCount);
for I := OutCount - 1 downto 0 do
Output(Byte(OutCode^[I]), OutCtxt);
OutCount := 0;
{ Update dictionary }
if not TableFull then begin
Prefix^[FreeCode] := OldCode;
Suffix^[FreeCode] := FinalChar;
{ Advance to next free slot }
Inc(FreeCode);
if (FreeCode >= MaxCode) then begin
if (ReadCtxt.CodeSize < 12) then begin
Inc(ReadCtxt.CodeSize);
MaxCode := MaxCode shl 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
end
else TableFull := True;
end;
end;
OldCode := InCode;
end;
Code := ReadCode(Stream, ReadCtxt);
end; { while }
if Code = $FFFF then //GifError('Read GIF Error');
begin
Corrupted := True;
//Break;
end;
//finally
//end;
//finally
FreeMem( OutCode {, SizeOf(TIntCodeTable) + SizeOf(Word)} );
//end;
//finally
FreeMem(Suffix {, SizeOf(TIntCodeTable)} );
//end;
//finally
FreeMem(Prefix {, SizeOf(TIntCodeTable)} );
//end;
end;
{ TGifFrame }
function NewGifFrame(AOwner: PGifDecoder): PGifFrame;
begin
new( Result, Create );
Result.FOwner := AOwner;
Result.FTransIndex := -1;
Result.FItem.FImageData := NewMemoryStream;
Result.FTranspColor := clNone;
end;
destructor TGifFrame.Destroy;
begin
FBitmap.Free;
FTransMask.Free;
FItem.FImageData.Free;
FreeExtensions( FExtensions );
inherited;
end;
procedure TGifFrame.Draw(DC : HDC; X, Y: Integer);
begin
GetBitmap; // create Mask if it is needed
if Mask = nil then
FBitmap.Draw( DC, X, Y )
else
DrawBitmapMask( DC, X, Y, FBitmap, FTransMask );
end;
function TGifFrame.FindComment(ForceCreate: Boolean): PStrList;
var
Ext: PExtension;
begin
Ext := FindExtension(FExtensions, etComment);
if (Ext = nil) and ForceCreate then
begin
new( Ext, Create );
Ext.FExtType := etComment;
if FExtensions = nil then FExtensions := NewList;
FExtensions.Add(Ext);
end;
if (Ext <> nil) then
begin
if (Ext.FList = nil) and ForceCreate then
Ext.FList := NewStrList;
Result := Ext.FList;
end
else Result := nil;
end;
procedure TGifFrame.FreeResources;
begin
if FBitmap <> nil then
FBitmap.Dormant;
if FTransMask <> nil then
FTransMask.Dormant;
end;
{procedure SnapStream2File( Strm: PStream; const Fname: String );
var PP: Integer;
FS: PStream;
begin
PP := Strm.Position;
Strm.Position := 0;
FS := NewWriteFileStream( Fname );
Stream2Stream( FS, Strm, Strm.Size );
FS.Free;
Strm.Position := PP;
end;}
function FillMaskLine4( Mask, Scan : PByte; W : Integer; TransIdx : Integer )
: Boolean;
assembler;
asm
PUSH ESI
PUSH EDI
PUSH EBX
MOV EDI, EAX
MOV ESI, EDX
MOV EDX, TransIdx
MOV DH, 0
INC ECX
SHR ECX, 1
JZ @@fin
MOV BX, 8000h
CLD
@@loop1:
LODSB
MOV AH, AL
SHR AH, 4
CMP AH, DL
JNZ @@1
OR BL, BH
MOV DH, BL
@@1: ROR BH, 1
AND AL, 0Fh
CMP AL, DL
JNZ @@2
OR BL, BH
MOV DH, BL
@@2: ROR BH, 1
JNC @@e_loop
MOV [EDI], BL
INC EDI
MOV BL, 0
@@e_loop:
LOOP @@loop1
CMP BH, 80h
JZ @@fin
MOV [EDI], BL
@@fin:
XOR EAX, EAX
MOV AL, DH
POP EBX
POP EDI
POP ESI
end;
{function FillMaskLine8( Mask, Scan : PByte; W : Integer; TransIdx : Integer )
: Boolean;
assembler;
asm
PUSH ESI
PUSH EDI
PUSH EBX
MOV EDI, EAX
MOV ESI, EDX
MOV EDX, TransIdx
MOV DH, 0
JECXZ @@fin
MOV BX, 8000h
CLD
@@loop1:
LODSB
CMP AL, DL
JNZ @@2
OR BL, BH
MOV DH, BL
@@2: ROR BH, 1
JNC @@e_loop
MOV [EDI], BL
INC EDI
MOV BL, 0
@@e_loop:
LOOP @@loop1
CMP BH, 80h
JZ @@fin
MOV [EDI], BL
@@fin:
XOR EAX, EAX
MOV AL, DH
POP EBX
POP EDI
POP ESI
end;
function FillMaskLine0( Mask, Scan : PByte; W : Integer )
: Boolean;
assembler;
asm
PUSH ESI
PUSH EDI
MOV EDI, EAX
MOV ESI, EDX
MOV EDX, 0
ADD ECX, 7
SHR ECX, 3
JZ @@fin
CLD
@@loop1:
LODSB
NOT AL
STOSB
OR DL, AL
LOOP @@loop1
@@fin:
MOV EAX, EDX
POP EDI
POP ESI
end;}
function FillMaskLine1( Mask, Scan : PByte; W : Integer )
: Boolean;
assembler;
asm
PUSH ESI
PUSH EDI
MOV EDI, EAX
MOV ESI, EDX
MOV EDX, 0
ADD ECX, 7
SHR ECX, 3
JZ @@fin
CLD
@@loop1:
LODSB
STOSB
OR DL, AL
LOOP @@loop1
@@fin:
MOV EAX, EDX
POP EDI
POP ESI
end;
{function FillMaskBitmap(Mask: PBitmap; Width, Height: Integer;
Bits: PByte; BitsPerPixel, LineWidth, TransIndex: Integer): Boolean;
var Y : Integer;
P, S : PByte;
begin
Result := False;
if TransIndex < 0 then Exit;
P := Mask.ScanLine[ 0 ];
if P = nil then Exit;
if BitsPerPixel = 4 then
for Y := Height - 1 downto 0 do
begin
P := Mask.ScanLine[ Y ];
S := Bits;
Result := FillMaskLine4( P, S, Width, TransIndex );
Inc( Bits, LineWidth );
end;
if BitsPerPixel = 8 then
for Y := Height - 1 downto 0 do
begin
P := Mask.ScanLine[ Y ];
S := Bits;
Result := FillMaskLine8( P, S, Width, TransIndex );
Inc( Bits, LineWidth );
end;
if BitsPerPixel = 1 then
for Y := Height - 1 downto 0 do
begin
P := Mask.ScanLine[ Y ];
S := Bits;
if Byte( TransIndex ) = 0 then
Result := FillMaskLine0( P, S, Width )
else
Result := FillMaskLine1( P, S, Width );
Inc( Bits, LineWidth );
end;
end;}
procedure ProvideTruthMask( Sender: PObj; var BIH: TBitmapInfoHeader; Bits: Pointer );
var Frame: PGifFrame;
begin
Frame := PGifFrame( Sender );
if Frame.FTransIndex >= 0 then
begin
Frame.FTransMask := NewBitmap( BIH.biWidth, BIH.biHeight );
Frame.FTransMask.PixelFormat := pf1bit;
//Frame.FReallyTransparent :=
{FillMaskBitmap( Frame.FTransMask, BIH.biWidth, BIH.biHeight, Bits,
BIH.biBitCount,
((BIH.biWidth * BIH.biBitCount + 31) div 32) * 4,
Frame.FTransIndex );}
end;
end;
function TGifFrame.GetBitmap: PBitmap;
var Mem : PStream;
function ConvertBitsPerPixel: TPixelFormat;
begin
case FItem.FBitsPerPixel of
1: Result := pf1bit;
2..4: Result := pf4bit;
5..8: Result := pf8bit;
else Result := pfDevice;
end;
end;
procedure SaveToBmpStream;
var
HeaderSize: Longword;
Length: Longword;
BIH: TBitmapInfoHeader;
BFH: TBitmapFileHeader;
Colors: TRGBPalette;
Bits: Pointer;
Corrupt: Boolean;
begin
with BIH do begin
biSize := Sizeof(TBitmapInfoHeader);
biWidth := FItem.FSize.X;
biHeight := FItem.FSize.Y;
biPlanes := 1;
biBitCount := 0;
case ConvertBitsPerPixel of
pf1bit: biBitCount := 1;
pf4bit: biBitCount := 4;
else biBitCount := 8;
end;
biCompression := BI_RGB;
biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
HeaderSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * (1 shl BIH.biBitCount);
Length := HeaderSize + BIH.biSizeImage;
Mem.Size := 0;
with BFH do begin
bfType := $4D42; { 'BM' }
bfSize := Length;
bfOffBits := HeaderSize;
end;
Mem.Write(BFH, SizeOf(TBitmapFileHeader));
Mem.Write(BIH, SizeOf(TBitmapInfoHeader));
FillRGBPalette(FItem.FColorMap, Colors);
Mem.Write(Colors, SizeOf(TRGBQuad) * (1 shl BIH.biBitCount));
Bits := AllocMemo(BIH.biSizeImage);
//try
ZeroMemory(Bits, BIH.biSizeImage);
FItem.FImageData.Seek( 0, spBegin );
ReadGIFData(FItem.FImageData, BIH, FInterlaced,
FItem.FBitsPerPixel, Bits, Corrupt);
FTransMask.Free;
FTransMask := nil;
if Assigned( FOwner.FOnNeedMask ) then
FOwner.FOnNeedMask( @Self, BIH, Bits );
(*
if FOwner.NeedMask then
begin
if FTransIndex >= 0 then
begin
FTransMask := NewBitmap( BIH.biWidth, BIH.biHeight );
FTransMask.PixelFormat := pf1bit;
FReallyTransparent :=
FillMaskBitmap( FTransMask, BIH.biWidth, BIH.biHeight, Bits,
BIH.biBitCount,
((BIH.biWidth * BIH.biBitCount + 31) div 32) * 4,
FTransIndex );
{if not ReallyTransparent then
begin
FTransMask.Free;
FTransMask := nil;
end;}
end;
end;
*)
FCorrupted := FCorrupted or Corrupt;
FOwner.FCorrupted := FOwner.FCorrupted or FCorrupted;
Mem.Write(Bits^, BIH.biSizeImage);
//finally
FreeMemo(Bits);
//end;
Mem.Seek( 0, spBegin );
end;
begin
if FBitmap = nil then
begin
New_Bitmap;
Mem := NewMemoryStream;
SaveToBmpStream;
//--SnapStream2File( Mem, GetStartDir + 'loaded_mem.bmp' );
FBitmap.LoadFromStream( Mem );
//--FBitmap.SaveToFile( GetStartDir + 'loaded.bmp' );
{$IFDEF TOPF16BIT}
FBitmap.PixelFormat := pf16bit; //&&& // ColorsToPixelFormat( 1 shl FItem.FBitsPerPixel );
{$ELSE}
FBitmap.PixelFormat := pf24bit;
{$ENDIF}
//FBitmap.FreeResources;
Mem.Free;
end;
Result := FBitmap;
end;
function TGifFrame.GetColorCount: Integer;
begin
Result := FItem.FColorMap.ColorCount;
Assert( Result <> 0, 'Unknown color count in gif frame bitmap' );
{if (Result = 0) and Assigned( FBitmap ) and (FBitmap.Palette <> 0) then
GetObject( FBitmap.Palette, Sizeof( Integer ), @Result );}
end;
function TGifFrame.GetComment: PStrList;
begin
Result := FindComment( True );
end;
function TGifFrame.GetHeight: Integer;
begin
if Assigned(FBitmap) or Assigned(FItem.FImageData) then
Result := Bitmap.Height
else Result := 0;
end;
function TGifFrame.GetReallyTransparent: Boolean;
begin
GetBitmap;
Result := fReallyTransparent;
end;
function TGifFrame.GetWidth: Integer;
begin
if Assigned(FBitmap) or Assigned(FItem.FImageData) then
Result := Bitmap.Width
else Result := 0;
end;
function TGifFrame.LoadFromStream(Stream: PStream): Boolean;
function DoLoadStream : Boolean;
var
ImageDesc: TImageDescriptor;
I, TransIndex: Integer;
begin
//Result := False;
fTransIndex := -1;
//
FItem.FImageData.Free;
FItem.FImageData := NewMemoryStream;
//
ReadImageStream(Stream, FItem.FImageData, ImageDesc, FInterlaced,
FLocalColors, FCorrupted, FItem.FBitsPerPixel, FItem.FColorMap);
FItem.FImageData.Position := 0;
with ImageDesc do
begin
FTopLeft := MakePoint(ImageLeftPos, ImageTopPos);
FItem.FSize := MakePoint(ImageWidth, ImageHeight);
FItem.FPackedFields := PackedFields;
end;
if not FLocalColors then
FItem.FColorMap := FOwner.FGifData.DColorMap;
FDelay := 0;
if FExtensions <> nil then
begin
for I := 0 to FExtensions.Count - 1 do
with PExtension(FExtensions.Items[I])^ do
if FExtType = etGraphic then
begin
if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then
begin
TransIndex := FExtRec.GCE.TransparentColorIndex;
if FItem.FColorMap.ColorCount > TransIndex then
begin
fTransIndex := TransIndex;
FTranspColor := ItemToRGB(FItem.FColorMap.Colors[TransIndex]);
FTransparent := True;
end;
end
else
FTranspColor := clNone;
FDelay := Max(FExtRec.GCE.DelayTime * 10, FDelay);
FDisposalMethod := TDisposeMethod((FExtRec.GCE.PackedFields and
GCE_DISPOSAL_METHOD) shr 2);
end;
end;
Result := True;
end;
begin
Result := DoLoadStream;
if not Result then
begin
FItem.FImageData.Free;
FItem.FImageData := nil;
end;
end;
procedure TGifFrame.New_Bitmap;
begin
FBitmap.Free;
FBitmap := NewBitmap( 0, 0 );
end;
procedure TGifFrame.SetComment(const Value: PStrList);
begin
GetComment.Assign( Value );
end;
procedure TGifFrame.SetDelay(const Value: Word);
begin
if FDelay = Value then Exit;
//FOwner.Changing;
FDelay := Value;
if FDelay > 0 then
FOwner.FVersion := gv89a;
//FOwner.Changed;
end;
procedure TGifFrame.SetDisposalMethod(const Value: TDisposeMethod);
begin
if FDisposalMethod = Value then Exit;
//FOwner.Changing;
FDisposalMethod := Value;
if Value <> dmUndefined then
FOwner.FVersion := gv89a;
//FOwner.Changed;
end;
procedure TGifFrame.SetTopLeft(const Value: TPoint);
begin
if (FTopLeft.X = Value.X) and (FTopLeft.Y = Value.Y) then Exit;
//FOwner.Changing;
FTopLeft := Value;
FOwner.FGifWidth := Max(FOwner.FGifWidth,
FItem.FSize.X + FTopLeft.X);
FOwner.FGifHeight := Max(FOwner.FGifHeight,
FItem.FSize.Y + FTopLeft.Y);
//FOwner.Changed;
end;
procedure TGifFrame.SetTranspColor(const Value: TColor);
begin
if FTranspColor = Value then Exit;
//FOwner.Changing;
if Value <> clNone then
FOwner.FVersion := gv89a;
FTranspColor := Value;
//FOwner.Changed;
end;
procedure TGifFrame.StretchDraw(DC: HDC; Rect: TRect);
var OldMode: Integer;
OldOrgX: TPoint;
begin
GetBitmap; // need to create Mask if it is needed
if Mask = nil then
begin
OldMode := SetStretchBltMode( DC, HALFTONE );
SetBrushOrgEx( DC, 0, 0, @ OldOrgX );
Bitmap.StretchDraw( DC, Rect );
SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil );
SetStretchBltMode( DC, OldMode );
end
else
begin
StretchBitmapMask( DC, Rect, Bitmap, Mask );
end;
end;
{ TGifDecoder }
procedure TGifDecoder.Clear;
begin
FGifData.DComment.Free;
FGifData.DComment := nil;
ClearItems;
FGifWidth := 0;
FGifHeight := 0;
FCorrupted := FALSE;
end;
procedure TGifDecoder.ClearItems;
var I: Integer;
begin
if FItems <> nil then
begin
for I := 0 to FItems.Count-1 do
PObj(FItems.Items[I]).Free;
FItems.Clear;
end;
end;
function NewGifDecoder: PGifDecoder;
begin
new( Result, Create );
Result.NewImage;
Result.FTransparent := True;
Result.FBkColor := clNone;
end;
destructor TGifDecoder.Destroy;
begin
Clear;
FItems.Free;
inherited;
end;
procedure TGifDecoder.FreeResources;
var I : Integer;
begin
if FItems <> nil then
for I := 0 to FItems.Count - 1 do
PGifFrame( FItems.Items[ I ] ).FreeResources;
end;
function TGifDecoder.GetBitmap: PBitmap;
begin
if (FItems.Count > 0) then begin
if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
Result := PGIFFrame(FItems.Items[FFrameIndex]).Bitmap
else Result := PGIFFrame(FItems.Items[0]).Bitmap
end
else
Result := nil;
end;
function TGifDecoder.GetComment: PStrList;
begin
Result := FGifData.DComment;
end;
function TGifDecoder.GetFrame: Integer;
begin
Result := FFrameIndex;
end;
function TGifDecoder.GetFrameCount: Integer;
begin
Result := 0;
if FItems <> nil then
Result := FItems.Count;
end;
function TGifDecoder.GetFrames(Idx: Integer): PGifFrame;
begin
Result := nil;
if Idx >= 0 then
Result := PGifFrame( FItems.Items[ Idx ] );
end;
function TGifDecoder.GetHeight: Integer;
begin
Result := FGifHeight;
end;
function TGifDecoder.GetMask: PBitmap;
begin
if (FItems.Count > 0) then begin
if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
Result := PGIFFrame(FItems.Items[FFrameIndex]).Mask
else Result := PGIFFrame(FItems.Items[0]).Mask
end
else
Result := nil;
end;
function TGifDecoder.GetWidth: Integer;
begin
Result := FGifWidth;
end;
function TGifDecoder.LoadFromFile(const FileName: String): Boolean;
var Strm : PStream;
begin
Strm := NewReadFileStream( FileName {, ofOpenRead or ofOpenExisting or ofShareDenyWrite} );
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TGifDecoder.LoadFromResourceID(Instance: HInst;
ResID: Integer): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TGifDecoder.LoadFromResourceName(Inst: HInst;
RsrcName: PChar): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Inst, PChar( RsrcName ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TGifDecoder.LoadFromStream(Stream: PStream): Boolean;
var
SeparatorChar: Char;
NewItem: PGIFFrame;
Extensions: PList;
ScreenDesc: TScreenDescriptor;
Data: PStream;
function ReadSignature(Stream: PStream) : Boolean;
var
I: TGIFVersion;
S: array[ 0..3 ] of Char;
begin
Result := False;
FVersion := gvUnknown;
S[ 3 ] := #0;
Stream.Read(S[0], 3);
//if CompareText(GIFSignature, S) <> 0 then
if GIFSignature <> S then
//GifError( 'Incorrect GIF Version' );
Exit;
Stream.Read(S[0], 3);
for I := Low(TGIFVersion) to High(TGIFVersion) do
//if CompareText(S, StrPas(GIFVersionStr[I])) = 0 then
if CompareMem( @S[ 0 ], PChar( GifVersionStr[ I ] ), 4 ) then
begin
FVersion := I;
Break;
end;
if FVersion = gvUnknown then
//GifError('Unknown GIF Version');
Exit;
Result := True;
end;
procedure ReadScreenDescriptor(Stream: PStream);
begin
Stream.Read(ScreenDesc, SizeOf(ScreenDesc));
FGifWidth := ScreenDesc.ScreenWidth;
FGifHeight := ScreenDesc.ScreenHeight;
FGifData.DAspectRatio := ScreenDesc.AspectRatio;
FGifData.DBitsPerPixel := 1 + (ScreenDesc.PackedFields and
LSD_COLOR_TABLE_SIZE);
FGifData.DColorResBits := 1 + (ScreenDesc.PackedFields and
LSD_COLOR_RESOLUTION) shr 4;
end;
procedure ReadGlobalColorMap(Stream: PStream);
begin
if (ScreenDesc.PackedFields and LSD_GLOBAL_COLOR_TABLE) <> 0 then
begin
FGifData.DColorMap.ColorCount := 1 shl FGifData.DBitsPerPixel;
Stream.Read( FGifData.DColorMap.Colors[0],
FGifData.DColorMap.ColorCount * SizeOf(TGIFColorItem) );
{if FGifData.DColorMap.ColorCount > ScreenDesc.BackgroundColorIndex then
begin
fBackIndex := ScreenDesc.BackgroundColorIndex;
FBkColor := ItemToRGB( FGifData.DColorMap.Colors[ fBackIndex ] );
end;}
fBackIndex := ScreenDesc.BackgroundColorIndex;
if fBackIndex >= FGifData.DColorMap.ColorCount then
fBackIndex := 0;
FBkColor := ItemToRGB( FGifData.DColorMap.Colors[fBackIndex] );
end;
end;
function ReadDataBlock(Stream: PStream): PStrList;
var
BlockSize: Byte;
S: string;
begin
Result := NewStrlist;
//try
repeat
Stream.Read(BlockSize, SizeOf(Byte));
if BlockSize <> 0 then begin
SetLength(S, BlockSize);
Stream.Read(S[1], BlockSize);
Result.Add(S);
end;
until (BlockSize = 0) or (Stream.Position >= Stream.Size);
//except
{
Result.Free;
raise;
}
//end;
end;
function ReadExtension(Stream: PStream): PExtension;
var
ExtensionLabel: Byte;
begin
//Result := TExtension.Create;
new( Result, Create );
//try
Stream.Read(ExtensionLabel, SizeOf(Byte));
if ExtensionLabel = ExtLabels[etGraphic] then
begin
{ graphic control extension }
Result.FExtType := etGraphic;
Stream.Read(Result.FExtRec.GCE, SizeOf(TGraphicControlExtension));
end
else
if ExtensionLabel = ExtLabels[etComment] then
begin
{ comment extension }
Result.FExtType := etComment;
Result.FList := ReadDataBlock(Stream);
end
else
if ExtensionLabel = ExtLabels[etPlainText] then
begin
{ plain text extension }
Result.FExtType := etPlainText;
Stream.Read(Result.FExtRec.PTE, SizeOf(TPlainTextExtension));
Result.FList := ReadDataBlock(Stream);
end
else
if ExtensionLabel = ExtLabels[etApplication] then
begin
{ application extension }
Result.FExtType := etApplication;
Stream.Read(Result.FExtRec.APPE, SizeOf(TAppExtension));
Result.FList := ReadDataBlock(Stream);
end
else
begin
//GifError('Unrecognized GIF Extention ' + IntToStr( ExtensionLabel ) );
//...
Result.Free;
Result := nil;
end;
//except
{
Result.Free;
raise;
}
//end;
end;
function ReadExtensionBlock(Stream: PStream; var SeparatorChar: Char): PList;
var
NewExt: PExtension;
begin
Result := nil;
//try
while SeparatorChar = CHR_EXT_INTRODUCER do
begin
NewExt := ReadExtension(Stream);
if (NewExt.FExtType = etPlainText) then
begin
{ plain text data blocks are not supported,
clear all previous readed extensions }
FreeExtensions(Result);
Result := nil;
end;
if (NewExt.FExtType in [etPlainText, etApplication]) then
begin
{ check for loop extension }
if NewExt.IsLoopExtension then
begin
FLooping := True;
FRepeatCount := Min( PWord( @NewExt.FList.Items[0][2] )^,
//MakeWord(Byte(NewExt.FList.Items[0][2]),
//Byte(NewExt.FList.Items[0][3])),
MAX_LOOP_COUNT);
end;
{ not supported yet, must be ignored }
NewExt.Free;
end
else
begin
if Result = nil then
Result := NewList;
Result.Add(NewExt);
end;
if Stream.Size > Stream.Position then
Stream.Read(SeparatorChar, SizeOf(Byte))
else
SeparatorChar := CHR_TRAILER;
end;
if (Result <> nil) and (Result.Count = 0) then
begin
Result.Free;
Result := nil;
end;
//except
{
if Result <> nil then Result.Free;
raise;
}
//end;
end;
function DoLoadStream : Boolean;
var
Size : Integer;
I, OldPos: Integer;
Ext: PExtension;
Idx : Integer;
begin
Size := Stream.Size - Stream.Position;
Result := False;
//Changing;
NewImage;
Idx := 0;
Data := NewMemoryStream;
//try
Data.Size := Size;
Stream.Read(Data.Memory^, Size);
if Size > 0 then
begin
Data.Seek( 0, spBegin );
if not ReadSignature(Data) then Exit;
ReadScreenDescriptor(Data);
ReadGlobalColorMap(Data);
Data.Read(SeparatorChar, SizeOf(Byte));
OldPos := -1;
while not (SeparatorChar in [CHR_TRAILER, #0]) and not
(Data.Position >= Data.Size) and (DWORD(OldPos) <> Data.Position) do
begin
OldPos := Data.Position;
Extensions := ReadExtensionBlock(Data, SeparatorChar);
if SeparatorChar = CHR_IMAGE_SEPARATOR then
begin
//try
NewItem := NewGIFFrame(@Self);
NewItem.fFrameIndex := Idx;
Inc( Idx );
//try
if FGifData.DColorMap.ColorCount > 0 then
NewItem.FItem.FBitsPerPixel :=
ColorsToBits(FGifData.DColorMap.ColorCount);
NewItem.FExtensions := Extensions;
Extensions := nil;
if not NewItem.LoadFromStream(Data) then
begin
NewItem.Free;
Exit;
end;
FItems.Add(NewItem);
//except
{
NewItem.Free;
raise;
}
//end;
if not (Data.Position >= Data.Size) then
begin
Data.Read(SeparatorChar, SizeOf(Byte));
while (SeparatorChar = #0) and (Data.Position < Data.Size) do
Data.Read(SeparatorChar, SizeOf(Byte));
end
else
SeparatorChar := CHR_TRAILER;
if not (SeparatorChar in [CHR_EXT_INTRODUCER,
CHR_IMAGE_SEPARATOR, CHR_TRAILER]) then
begin
SeparatorChar := #0;
{GifError(LoadStr(SGIFDecodeError));}
//Corrupted := TRUE;
//break;
end;
//except
{
FreeExtensions(Extensions);
raise;
}
//end
end
else
if (FGifData.DComment.Count = 0) and (Extensions <> nil) then
begin
//try
{ trailig extensions }
for I := 0 to Extensions.Count - 1 do
begin
Ext := Extensions.Items[I];
if (Ext <> nil) and (Ext.FExtType = etComment) then
begin
if FGifData.DComment.Count > 0 then
FGifData.DComment.Add(#13#10#13#10);
FGifData.DComment.AddStrings(Ext.FList);
end;
end;
//finally
FreeExtensions(Extensions);
//end;
end
else
if not (SeparatorChar in [CHR_TRAILER, #0]) then
begin
//GifError('GIF Read Error');
//...
FreeExtensions(Extensions);
FCorrupted := TRUE;
end;
end;
end;
//finally
//Data.Free;
//end;
if Count > 0 then
begin
FFrameIndex := 0;
//if ForceDecode then
//try
GetBitmap; { force bitmap creation }
FTransparent := Frames[ 0 ].FTransparent;
//except
{
Frames[0].Free;
FItems.Delete(0);
raise;
}
//end;
end;
//Changed;
//if not Corrupted then
Result := True;
end;
begin
Clear;
Result := DoLoadStream;
Data.Free;
if not Result then Clear;
end;
procedure TGifDecoder.NewImage;
begin
FGifData.DComment.Free;
FGifData.DComment := NewStrList;
if FItems = nil then FItems := NewList;
ClearItems;
FFrameIndex := -1;
FBkColor := clNone;
FRepeatCount := 1;
FLooping := False;
FVersion := gvUnknown;
end;
procedure TGifDecoder.SetFrame(Value: Integer);
begin
If FFrameIndex = Value Then Exit;
//Changing;
FFrameIndex:= Value;
If (FFrameIndex >= FItems.Count) Or (FFrameIndex < 0) Then FFrameIndex:= 0;
//Changed;
end;
procedure TGifDecoder.SetNeedMask(const Value: Boolean);
begin
FNeedMask := Value;
if Value then
FOnNeedMask := ProvideTruthMask
else
FOnNeedMask := nil;
end;
{ TGif }
function NewGifNoMask: PGif;
begin
new( Result, Create );
Result.FGifImage := NewGifDecoder;
end;
function NewGif: PGif;
begin
Result := NewGifNoMask;
Result.FGifImage.NeedMask := TRUE;
end;
procedure TGif.Clear;
begin
FGifImage.Clear;
FCurIndex := -1;
FCurFrame.Free; FCurFrame := nil;
FCurMask.Free; FCurMask := nil;
FPrevFrame.Free; FPrevFrame := nil;
FPrevMask.Free; FPrevMask := nil;
Changed;
end;
destructor TGif.Destroy;
begin
//OnChanging := nil;
//OnChanged := nil;
Clear;
FGifImage.Free;
inherited;
end;
procedure TGif.Draw(DC: HDC; X, Y: Integer);
begin
if Count = 0 then Exit;
PrepareFrame;
FCurFrame.Draw( DC, X, Y );
end;
procedure TGif.DrawTransp(DC: HDC; X, Y: Integer);
begin
If Count > 0 Then DrawTransparent( DC, X, Y, Frames[ Frame ].TranspColor );
end;
procedure MyDraw(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer; Bmp, Msk: PBitmap);
begin
BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Msk.Canvas.Handle, 0, 0, ROP_DstAndNotSrc);
BitBlt(DC, X, Y, iWidth, iHeight, Msk.Canvas.Handle, SrcX, SrcY, SrcAnd);
BitBlt(DC, X, Y, iWidth, iHeight, Bmp.Canvas.Handle, SrcX, SrcY, SrcPaint);
end;
procedure TGif.DrawTransparentEx(DC: hDC; X, Y, iWidth, iHeight, SrcX, SrcY: Integer);
begin
If Count = 0 then Exit;
PrepareFrame;
If FCurMask = Nil Then
BitBlt(DC, X, Y, iWidth, iHeight, FCurFrame.Canvas.Handle, SrcX, SrcY, SrcCopy)
Else
MyDraw(DC, X, Y, iWidth, iHeight, SrcX, SrcY, FCurFrame, FCurMask);
end;
procedure TGif.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
begin
if Count = 0 then Exit;
PrepareFrame;
//-----------------------------------------------------------------------
{if FCurMask <> nil then
FCurMask.SaveToFile( GetStartDir + 'TGif.DrawTransparent.FCurMask.bmp' )
else
DeleteFile( PChar( GetStartDir + 'TGif.DrawTransparent.FCurMask.bmp' ) );
if FCurFrame <> nil then
FCurFrame.SaveToFile( GetStartDir + 'TGif.DrawTransparent.FCurFrame.bmp' )
else
DeleteFile( PChar( GetStartDir + 'TGif.DrawTransparent.FCurFrame.bmp' ) );}
//-------------------------------------------------------------------------
if FCurMask = Nil Then
FCurFrame.Draw( DC, X, Y )
Else
DrawBitmapMask( DC, X, Y, FCurFrame, FCurMask );
end;
procedure TGif.FreeResources;
begin
FGifImage.FreeResources;
if FCurFrame <> nil then
FCurFrame.Dormant;
if FCurMask <> nil then
FCurMask.Dormant;
if FPrevFrame <> nil then
FPrevFrame.Dormant;
if FPrevMask <> nil then
FPrevMask.Dormant;
end;
function TGif.GetHeight: Integer;
begin
Result := FGifImage.Height;
end;
function TGif.GetWidth: Integer;
begin
Result := FGifImage.Width;
end;
procedure TGif.StretchDrawTransp(DC: HDC; const Dest: TRect);
begin
if Count = 0 then Exit;
StretchDrawTransparent( DC, Dest, BkColor );
end;
procedure TGif.StretchDraw(DC: HDC; const Dest: TRect);
var OldMode: Integer; OldOrgX: TPoint;
begin
if Count = 0 then Exit;
PrepareFrame;
OldMode := SetStretchBltMode( DC, HALFTONE );
SetBrushOrgEx( DC, 0, 0, @ OldOrgX );
FCurFrame.StretchDraw( DC, Dest );
SetBrushOrgEx( DC, OldOrgX.x, OldOrgX.y, nil );
SetStretchBltMode( DC, OldMode );
end;
procedure TGif.StretchDrawTransparent(DC: HDC; const Dest: TRect; TranspColor: TColor);
begin
if Count = 0 then Exit;
PrepareFrame;
if FCurMask = nil then
FCurFrame.StretchDraw( DC, Dest )
else
StretchBitmapMask( DC, Dest, FCurFrame, FCurMask );
end;
procedure TGif.PrepareFrame;
var DM : TDisposeMethod; I : Integer;
procedure DrawCurFrameMask;
var F: PGifFrame;
begin
F := Frames[ FCurIndex ];
F.GetBitmap;
//if F.ReallyTransparent then
if F.Mask <> nil then
begin
BitBlt( FCurMask.Canvas.Handle,
F.Origin.x,
F.Origin.y,
F.Origin.X + F.Width,
F.Origin.Y + F.Height,
F.Mask.Canvas.Handle, 0, 0, SRCAND );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
end
else
begin
//^^^FCurMask.Canvas.Brush.Color := clBlack;
FCurMask.BkColor := clBlack;
FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y,
F.Origin.x + F.Width, F.Origin.y + F.Height ) );
end;
end;
procedure Prepare0;
var Frame0: PGifFrame;
begin
FCurIndex := 0;
Frame0 := Frames[ 0 ];
FCurFrame.PixelFormat := Frame0.Bitmap.PixelFormat;
//^^^FCurFrame.Canvas.Brush.Color := BkColor;
FCurFrame.BkColor := BkColor;
FCurFrame.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) );
if FCurMask <> nil then
begin
//^^^FCurMask.Canvas.Brush.Color := clWhite;
FCurMask.BkColor := clWhite;
FCurMask.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) );
end;
Frame0.Draw( FCurFrame.Canvas.Handle, Frame0.Origin.x, Frame0.Origin.y );
//FCurFrame.SaveToFile( GetStartDir + '0_Frame.bmp' );
if FCurMask <> nil then
begin
DrawCurFrameMask;
//FCurMask.SaveToFile( GetStartDir + '0_Mask.bmp' );
end;
end;
var F: PGifFrame;
begin
if Count = 0 then Exit;
if FCurFrame = nil then
begin
FCurFrame := NewBitmap( Width, Height );
{$IFDEF TOPF16BIT}
FCurFrame.PixelFormat := pf16bit; //&&&
{$ELSE}
FCurFrame.PixelFormat := pf24bit;
{$ENDIF}
if Transparent then
begin
FCurMask := NewBitmap( Width, Height );
FCurMask.PixelFormat := pf1bit;
end;
FCurIndex := -1;
end;
if FCurIndex >= 0 then
if Frames[ FCurIndex ].ReallyTransparent then
if FCurMask = nil then
begin
FCurMask := NewBitmap( Width, Height );
FCurMask.PixelFormat := pf1bit;
//^^^FCurMask.Canvas.Brush.Color := clWhite;
FCurMask.BkColor := clBlack; //---%%%---
FCurMask.Canvas.FillRect( MakeRect( 0, 0, Width, Height ) );
end;
if (FCurIndex < 0) or (FCurIndex > Frame) then
Prepare0;
while FCurIndex < Frame do
begin
DM := Frames[ FCurIndex ].DisposalMethod;
if DM = dmRestorePrevious then
if FCurIndex = 0 then
DM := dmRestoreBackground;
if DM = dmUndefined then
for I := FCurIndex - 1 downto 0 do
if Frames[ I ].DisposalMethod <> DM then
begin
DM := Frames[ I ].DisposalMethod;
break;
end;
if (DM = dmUndefined) and Frames[ FCurIndex + 1 ].Transparent then
DM := dmLeave;
case DM of
dmRestoreBackground:
begin
//^^^FCurFrame.Canvas.Brush.Color := BkColor;
FCurFrame.BkColor := BkColor;
F := Frames[ FCurIndex ];
FCurFrame.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y, F.Origin.x + F.Width,
F.Origin.y + F.Height ) );
if FCurMask <> nil then
begin
//^^^FCurMask.Canvas.Brush.Color := clWhite;
FCurMask.BkColor := clWhite;
if FCurIndex < Count then
begin
Frames[ FCurIndex + 1 ].GetBitmap;
if Frames[ FCurIndex + 1 ].Mask = nil then
//^^^FCurMask.Canvas.Brush.Color := clBlack;
FCurMask.BkColor := clBlack;
end;
FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y,
F.Origin.x + F.Width, F.Origin.y + F.Height ) );
end;
end;
dmRestorePrevious:
begin
FCurFrame.Assign( FPrevFrame );
if FCurMask <> nil then
FCurMask.Assign( FPrevMask );
if FCurMask <> nil then
if FCurMask.Empty then
begin
FCurMask.Free;
FCurMask := nil;
end;
end;
dmUndefined:
begin
F := Frames[ FCurIndex + 1 ];
//^^^FCurFrame.Canvas.Brush.Color := BkColor;
FCurFrame.BkColor := BkColor;
FCurFrame.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y,
F.Origin.x + F.Width, F.Origin.y + F.Height ) );
if FCurMask <> nil then
begin
//^^^FCurMask.Canvas.Brush.Color := clBlack;
FCurMask.BkColor := clBlack;
FCurMask.Canvas.FillRect( MakeRect( F.Origin.x, F.Origin.y,
F.Origin.x + F.Width, F.Origin.y + F.Height ) );
end;
end;
end;
Inc( FCurIndex );
F := Frames[ FCurIndex ];
if F.DisposalMethod = dmRestorePrevious then
begin
if FPrevFrame = nil then
FPrevFrame := NewBitmap( 0, 0 );
FPrevFrame.Assign( FCurFrame );
if FCurMask <> nil then
begin
if FPrevMask = nil then
FPrevMask := NewBitmap( 0, 0 );
FPrevMask.Assign( FCurMask );
end;
end;
F.Draw( FCurFrame.Canvas.Handle, F.Origin.x, F.Origin.y );
//F.Bitmap.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + 'img.bmp' );
//FCurFrame.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + '=fr.bmp' );
if FCurMask <> nil then
begin
//if F.Mask <> nil then F.Mask.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + 'Msk.bmp' );
DrawCurFrameMask;
//---------------------
//FCurMask.SaveToFile( GetStartDir + Int2Str( FCurIndex ) + '=MS.bmp' );
//---------------------
end;
end;
end;
function TGif.GetBkColor: TColor;
begin
Result := FGifImage.BkColor;
end;
procedure TGif.SetBkColor(const Value: TColor);
begin
FGifImage.BkColor := Value;
Changed;
end;
function TGif.GetFrames(Idx: Integer): PGifFrame;
begin
Result := FGifImage.Frames[ Idx ];
end;
function TGif.GetTransparent: Boolean;
begin
Result := FGifImage.Transparent;
end;
function TGif.GetFrame: Integer;
begin
Result := FGifImage.FFrameIndex;
end;
procedure TGif.SetFrame(Value: Integer);
begin
if Value >= Count then
Value := 0;
FGifImage.Frame := Value;
end;
function TGif.LoadFromStream(Stream: PStream): Boolean;
begin
Clear;
Result := FGifImage.LoadFromStream( Stream );
Changed;
end;
function TGif.LoadFromFile(const FileName: String): Boolean;
begin
Clear;
Result := FGifImage.LoadFromFile( FileName );
Changed;
end;
function TGif.GetFrameCount: Integer;
begin
Result := FGifImage.Count;
end;
function TGif.GetDelays(Idx: Integer): Integer;
begin
Result := 0;
if Idx < Count then
Result := Frames[ Idx ].Delay;
end;
procedure TGif.SetDelays(Idx, Value: Integer);
begin
Frames[ Idx ].Delay := Value;
Changed;
end;
procedure TGif.SetWidth(Value: Integer);
begin
// nothing!
end;
procedure TGif.SetHeight(Value: Integer);
begin
// nothing !
end;
{
procedure TGif.SetForceBkTransparent(const Value: Boolean);
begin
if FForceBkTransparent = Value then Exit;
FForceBkTransparent := Value;
FCurIndex := -1;
end;
}
function TGif.GetCorrupted: Boolean;
begin
Result := FGifImage.Corrupted;
end;
procedure TGif.Changed;
begin
if Assigned( FOnChanged ) then
FOnChanged( @Self );
end;
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//+ TGifShow - a control to show (animated) GIF on a form. +
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
type
PGifShowData = ^TGifShowData;
TGifShowData = object( TObj )
gsdGifShow: PGifShow;
gsdAutosize: Boolean;
gsdStretch: Boolean;
gsdAnimate: Boolean;
gsdLoop: Boolean;
//gsdTimer: PTimer;
gsdTimerSet: Integer;
gsdGif: PGif;
gsdOnEndLoop: TOnEvent;
destructor Destroy; virtual;
end;
function NewGifShow( AParent: PControl ): PGifShow;
var D: PGifShowData;
begin
Result := PGifShow( NewPaintBox( AParent ) );
new( D, Create );
D.gsdGifShow := Result;
D.gsdAutosize := TRUE;
D.gsdStretch := TRUE;
D.gsdAnimate := TRUE;
D.gsdLoop := TRUE;
D.gsdGif := NewGif;
D.gsdGif.FOnChanged := Result.GifChanged;
Result.CustomObj := D;
Result.SetOnPaint( Result.PaintFrame );
end;
function TGif.LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TGif.LoadFromResourceName(Inst: HInst; RsrcName: PChar): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Inst, PChar( RsrcName ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
{ TGifShow }
function TGifShow.GetAnimate: Boolean;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdAnimate;
end;
function TGifShow.GetAutosize: Boolean;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdAutosize;
end;
function TGifShow.GetDummy: Boolean;
begin
Result := FALSE;
end;
function TGifShow.GetGif: PGif;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdGif;
end;
function TGifShow.GetLoop: Boolean;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdLoop;
end;
function TGifShow.GetOnEndLoop: TOnEvent;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdOnEndLoop;
end;
function TGifShow.GetStretch: Boolean;
var D: PGifShowData;
begin
D := Pointer( CustomObj );
Result := D.gsdStretch;
end;
procedure GoNextFrame( Wnd: HWnd; Msg: DWORD; GifShow: PGifShow; dwTime: DWORD );
stdcall;
begin
GifShow.NextFrame( nil );
end;
procedure TGifShow.GifChanged(Sender: PObj);
var D: PGifShowData;
NewDelay: Integer;
begin
D := Pointer( CustomObj );
if (D.gsdGif.Count > 1) and D.gsdAnimate then
begin
NewDelay := Max( 1, D.gsdGif.Frames[ 0 ].Delay );
if D.gsdTimerSet = 0 then
begin
D.gsdTimerSet := NewDelay;
SetTimer( GetWindowHandle, DWORD( @ Self ), D.gsdTimerSet, @ GoNextFrame );
end;
end
else
if D.gsdTimerSet <> 0 then
begin
KillTimer( Handle, DWORD( @ Self ) );
D.gsdTimerSet := 0;
end;
if D.gsdAutosize then
SetAutosize( TRUE );
Invalidate;
end;
function TGifShow.LoadFromFile(const FileName: String): Boolean;
begin
Result := Gif.LoadFromFile( FileName );
end;
function TGifShow.LoadFromResourceID(Instance: HInst;
ResID: Integer): Boolean;
begin
Result := Gif.LoadFromResourceID( Instance, ResID );
end;
function TGifShow.LoadFromResourceName(Inst: HInst;
RsrcName: PChar): Boolean;
begin
Result := Gif.LoadFromResourceName( Inst, RsrcName );
end;
function TGifShow.LoadFromStream(Stream: PStream): Boolean;
begin
Result := Gif.LoadFromStream( Stream );
end;
procedure TGifShow.NextFrame(Sender: PObj);
var D: PGifShowData;
NewDelay: Integer;
begin
D := Pointer( CustomObj );
if D.gsdGif.Frame >= D.gsdGif.Count-1 then
begin
if D.gsdLoop then
begin
D.gsdGif.Frame := 0;
//D.gsdTimer.Interval := D.gsdGif.Frames[ 0 ].Delay;
end
else
begin
D.gsdAnimate := FALSE;
end;
if Assigned( D.gsdOnEndLoop ) then
D.gsdOnEndLoop( @ Self );
end
else
D.gsdGif.Frame := D.gsdGif.Frame + 1;
Invalidate;
NewDelay := Max( 1, D.gsdGif.Frames[ D.gsdGif.Frame ].Delay );
if D.gsdTimerSet <> NewDelay then
begin
if D.gsdTimerSet <> 0 then
KillTimer( Handle, DWORD( @Self ) );
D.gsdTimerSet := NewDelay;
SetTimer( Handle, DWORD( @ Self ), NewDelay, @ GoNextFrame );
end;
end;
procedure TGifShow.PaintFrame(Sender: PControl; DC: HDC);
var D: PGifShowData;
Br: HBrush;
begin
D := Pointer( CustomObj );
if (D.gsdGif.Width > 0) and (D.gsdGif.Height > 0) then
begin
if Stretch and ((D.gsdGif.Width <> Width) or (D.gsdGif.Height <> Height)) then
if Transparent then
D.gsdGif.StretchDrawTransp( DC, ClientRect )
else
D.gsdGif.StretchDraw( DC, ClientRect )
else
if Transparent then
D.gsdGif.DrawTransp( DC, 0, 0 )
else
D.gsdGif.Draw( DC, 0, 0 );
end
else
begin
if not Transparent then
begin
Br := CreateSolidBrush( Color2RGB( Color ) );
Windows.FillRect( DC, ClientRect, Br );
DeleteObject( Br );
end;
end;
end;
procedure TGifShow.SetAnimate(const Value: Boolean);
var D: PGifShowData;
begin
D := Pointer( CustomObj );
D.gsdAnimate := Value;
GifChanged( nil );
end;
procedure TGifShow.SetAutosize(const Value: Boolean);
var D: PGifShowData;
begin
D := Pointer( CustomObj );
D.gsdAutosize := Value;
if Value and (D.gsdGif.Width > 0) and (D.gsdGif.Height > 0) then
begin
Width := D.gsdGif.Width;
Height := D.gsdGif.Height;
end;
end;
procedure TGifShow.SetLoop(const Value: Boolean);
var D: PGifShowData;
begin
D := Pointer( CustomObj );
if D.gsdLoop = Value then Exit;
D.gsdLoop := Value;
GifChanged( nil );
end;
procedure TGifShow.SetOnEndLoop(const Value: TOnEvent);
var D: PGifShowData;
begin
D := Pointer( CustomObj );
D.gsdOnEndLoop := Value;
end;
procedure TGifShow.SetStretch(const Value: Boolean);
var D: PGifShowData;
begin
D := Pointer( CustomObj );
D.gsdStretch := Value;
Invalidate;
end;
{ TGifShowData }
destructor TGifShowData.Destroy;
begin
//gsdTimer.Free;
if gsdTimerSet <> 0 then
KillTimer( gsdGifShow.Handle, DWORD( gsdGifShow ) );
gsdGif.Free;
inherited;
end;
end.
Reference in New Issue View Git Blame Copy Permalink