pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
master
lazarus-ccr/components/jvcllaz/run/JvMM/jvgif.pas

3100 lines
82 KiB
ObjectPascal
Raw Permalink Blame History

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvGIF.PAS, released on 2002-07-04.
The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 2001,2002 SGB Software
All Rights Reserved.
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
GIF support is native for VisualCLX so this file is VCL only // <-- wp: really?
Transparency does not seem to work
-----------------------------------------------------------------------------}
// $Id$
unit JvGIF;
{$mode objfpc}{$H+}
interface
uses
LCLType, LCLIntf, Types, RTLConsts,
SysUtils, Classes, Graphics, Controls;
const
RT_GIF = 'GIF'; { GIF Resource Type }
type
TGIFVersion = (gvUnknown, gv87a, gv89a);
TGIFBits = 1..8;
TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,
dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
TGIFColorItem = packed record
Red: Byte;
Green: Byte;
Blue: Byte;
end;
TGIFColorTable = packed record
Count: Integer;
Colors: packed array [Byte] of TGIFColorItem;
end;
TJvGIFFrame = class;
TGIFData = class;
TGIFItem = class;
TJvGIFImage = class(TGraphic)
private
FImage: TGIFData;
FVersion: TGIFVersion;
FItems: TList;
FFrameIndex: Integer;
FScreenWidth: Word;
FScreenHeight: Word;
FBackgroundColor: TColor;
FLooping: Boolean;
FCorrupted: Boolean;
FRepeatCount: Word;
FTransparent: Boolean;
function GetBitmap: TBitmap;
function GetCount: Integer;
function GetComment: TStrings;
function GetScreenWidth: Integer;
function GetScreenHeight: Integer;
function GetGlobalColorCount: Integer;
procedure UpdateScreenSize;
procedure SetComment(Value: TStrings);
function GetFrame(Index: Integer): TJvGIFFrame;
procedure SetFrameIndex(Value: Integer);
procedure SetBackgroundColor(Value: TColor);
procedure SetLooping(Value: Boolean);
procedure SetRepeatCount(Value: Word);
procedure ReadSignature(Stream: TStream);
procedure DoProgress(Stage: TProgressStage; PercentDone: Byte;
const Msg: string);
function GetCorrupted: Boolean;
function GetTransparentColor: TColor;
function GetBackgroundColor: TColor;
function GetPixelFormat: TPixelFormat;
procedure EncodeFrames(ReverseDecode: Boolean);
procedure ReadStream(Size: Longint; Stream: TStream; ForceDecode: Boolean);
procedure WriteStream(Stream: TStream; WriteSize: Boolean);
protected
procedure AssignTo(Dest: TPersistent); override;
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
function Equals(Graphic: TGraphic): Boolean; override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
function GetPalette: HPALETTE; override;
function GetTransparent: Boolean; override;
procedure ClearItems;
procedure NewImage;
procedure UniqueImage;
procedure ReadData(Stream: TStream); override;
procedure SetHeight({%H-}Value: Integer); override;
procedure SetTransparent(Value: Boolean); override;
procedure SetWidth({%H-}Value: Integer); override;
procedure WriteData(Stream: TStream); override;
property Bitmap: TBitmap read GetBitmap; { volatile }
public
constructor Create; override;
destructor Destroy; override;
procedure Clear; override;
procedure DecodeAllFrames;
procedure EncodeAllFrames;
procedure Assign(Source: TPersistent); override;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToStream(Stream: TStream); override;
(*************** NOT CONVERTED ***
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
**********************************)
procedure LoadFromResourceName(Instance: THandle; const ResName: string); override;
procedure LoadFromResourceID(Instance: THandle; ResID: Integer); override;
function AddFrame(Value: TGraphic): Integer; virtual;
procedure DeleteFrame(Index: Integer);
procedure MoveFrame(CurIndex, NewIndex: Integer);
procedure Grayscale(ForceEncoding: Boolean);
property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
property Comment: TStrings read GetComment write SetComment;
property Corrupted: Boolean read GetCorrupted;
property Count: Integer read GetCount;
property Frames[Index: Integer]: TJvGIFFrame read GetFrame; default;
property FrameIndex: Integer read FFrameIndex write SetFrameIndex;
property GlobalColorCount: Integer read GetGlobalColorCount;
property Looping: Boolean read FLooping write SetLooping;
property PixelFormat: TPixelFormat read GetPixelFormat;
property RepeatCount: Word read FRepeatCount write SetRepeatCount;
property ScreenWidth: Integer read GetScreenWidth;
property ScreenHeight: Integer read GetScreenHeight;
property TransparentColor: TColor read GetTransparentColor;
property Version: TGIFVersion read FVersion;
end;
TJvGIFFrame = class(TPersistent)
private
FOwner: TJvGIFImage;
FBitmap: TBitmap;
FImage: TGIFItem;
FExtensions: TList;
FTopLeft: TPoint;
FInterlaced: Boolean;
FCorrupted: Boolean;
FGrayscale: Boolean;
FTransparentColor: TColor;
FAnimateInterval: Word;
FDisposal: TDisposalMethod;
FLocalColors: Boolean;
function GetBitmap: TBitmap;
function GetHeight: Integer;
function GetWidth: Integer;
function GetColorCount: Integer;
function FindComment(ForceCreate: Boolean): TStrings;
function GetComment: TStrings;
procedure SetComment(Value: TStrings);
procedure SetTransparentColor(Value: TColor);
procedure SetDisposalMethod(Value: TDisposalMethod);
procedure SetAnimateInterval(Value: Word);
procedure SetTopLeft(const Value: TPoint);
procedure NewBitmap;
procedure NewImage;
procedure SaveToBitmapStream(Stream: TMemoryStream);
procedure EncodeBitmapStream(Stream: TMemoryStream);
procedure EncodeRasterData;
procedure UpdateExtensions;
procedure WriteImageDescriptor(Stream: TStream);
procedure WriteLocalColorMap(Stream: TStream);
procedure WriteRasterData(Stream: TStream);
protected
procedure LoadFromStream(Stream: TStream);
procedure AssignTo(Dest: TPersistent); override;
procedure GrayscaleImage(ForceEncoding: Boolean);
public
constructor Create(AOwner: TJvGIFImage); virtual;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Draw(ACanvas: TCanvas; const ARect: TRect;
Transparent: Boolean);
property AnimateInterval: Word read FAnimateInterval write SetAnimateInterval;
property Bitmap: TBitmap read GetBitmap; { volatile }
property ColorCount: Integer read GetColorCount;
property Comment: TStrings read GetComment write SetComment;
property DisposalMethod: TDisposalMethod read FDisposal write SetDisposalMethod;
property Interlaced: Boolean read FInterlaced;
property Corrupted: Boolean read FCorrupted;
property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
property Origin: TPoint read FTopLeft write SetTopLeft;
property Height: Integer read GetHeight;
property Width: Integer read GetWidth;
end;
TGIFData = class(TSharedRasterImage) //was: TSharedImage)
private
FComment: TStringList;
FAspectRatio: Byte;
FBitsPerPixel: Byte;
FColorResBits: Byte;
FColorMap: TGIFColorTable;
protected
procedure FreeHandle; override;
public
constructor Create; override;
destructor Destroy; override;
end;
TGIFItem = class(TSharedRasterImage) //was: TSharedImage)
private
FImageData: TMemoryStream;
FSize: TPoint;
FPackedFields: Byte;
FBitsPerPixel: Byte;
FColorMap: TGIFColorTable;
protected
procedure FreeHandle; override;
public
destructor Destroy; override;
end;
var
CF_JVGIF: UINT; { Clipboard format for GIF image }
{ Load incomplete or corrupted images without exceptions }
// (rom) changed to var to allow changes
var
GIFLoadCorrupted: Boolean = True;
function GIFVersionName(Version: TGIFVersion): string;
procedure JvGif_Dummy;
implementation
uses
//Consts,
FPImage, Math, ClipBrd,
JvJVCLUtils, JvResources, JvTypes;
// JvJCLUtils, JvJVCLUtils, JvAni, JvConsts, JvResources, JvTypes;
const
CrLf = #13#10;
{$RANGECHECKS OFF}
procedure JvGif_Dummy;
begin
end;
procedure GifError(const Msg: String);
begin
raise EInvalidGraphicOperation.Create(Msg);
end;
(*
procedure GifError(const Msg: string);
procedure ThrowException(const Msg: string; ReturnAddr: Pointer);
begin
raise EInvalidGraphicOperation.Create(Msg) at ReturnAddr;
end;
asm
{$IFDEF CPU32}
pop edx
{$ENDIF CPU32}
{$IFDEF CPU64}
pop rdx
{$ENDIF CPU64}
jmp ThrowException
end;
*)
{$IFDEF RANGECHECKS_ON}
{$RANGECHECKS ON}
{$ENDIF RANGECHECKS_ON}
//=== { TSharedImage } =======================================================
type
TGifSignature = array [0..2] of AnsiChar;
const
GIFSignature: TGifSignature = 'GIF';
GIFVersionStr: array [TGIFVersion] of TGifSignature = (#0#0#0, '87a', '89a');
function GIFVersionName(Version: TGIFVersion): string;
begin
Result := string(GIFVersionStr[Version]);
end;
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
Result := 0;
for I := Low(TGIFBits) to High(TGIFBits) do
if ColorCount = GIFColors[I] then
begin
Result := I;
Exit;
end;
GifError(RsEWrongGIFColors);
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;
end;
function ItemToRGB(Item: TGIFColorItem): Longint;
begin
with Item do
Result := RGB(Red, Green, Blue);
end;
function GrayColor(Color: TColor): TColor;
var
Index: Integer;
begin
Index := Byte(Longint(Word(GetRValue(Color)) * 77 +
Word(GetGValue(Color)) * 150 + Word(GetBValue(Color)) * 29) shr 8);
Result := RGB(Index, Index, Index);
end;
procedure GrayColorTable(var ColorTable: TGIFColorTable);
var
I: Byte;
Index: Integer;
begin
for I := 0 to ColorTable.Count - 1 do
begin
with ColorTable.Colors[I] do
begin
Index := Byte(Longint(Word(Red) * 77 + Word(Green) * 150 + Word(Blue) * 29) shr 8);
Red := Index;
Green := Index;
Blue := Index;
end;
end;
end;
function FindColorIndex(const ColorTable: TGIFColorTable;
Color: TColor): Integer;
begin
if Color <> clNone then
for Result := 0 to ColorTable.Count - 1 do
if ItemToRGB(ColorTable.Colors[Result]) = ColorToRGB(Color) then
Exit;
Result := -1;
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: TGifSignature; { contains 'GIF' }
Version: TGifSignature; { '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);
LoopExtNS: string[11] = 'NETSCAPE2.0';
LoopExtAN: string[11] = 'ANIMEXTS1.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: Word;
Top: Word;
Width: Word;
Height: Word;
CellWidth: Byte;
CellHeight: Byte;
FGColorIndex: Byte;
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;
//=== { TExtension } =========================================================
type
TExtension = class(TPersistent)
private
FExtType: TExtensionType;
FData: TStringList;
FExtRec: TExtensionRecord;
public
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function IsLoopExtension: Boolean;
end;
destructor TExtension.Destroy;
begin
FData.Free;
inherited Destroy;
end;
procedure TExtension.Assign(Source: TPersistent);
begin
if (Source <> nil) and (Source is TExtension) then
begin
FExtType := TExtension(Source).FExtType;
FExtRec := TExtension(Source).FExtRec;
if TExtension(Source).FData <> nil then
begin
if FData = nil then
FData := TStringList.Create;
FData.Assign(TExtension(Source).FData);
end;
end
else
inherited Assign(Source);
end;
function TExtension.IsLoopExtension: Boolean;
begin
Result := (FExtType = etApplication) and (FData.Count > 0) and
(CompareMem(@FExtRec.APPE.AppId, @LoopExtNS[1], FExtRec.APPE.BlockSize) or
CompareMem(@FExtRec.APPE.AppId, @LoopExtAN[1], FExtRec.APPE.BlockSize)) and
(Length(FData[0]) >= 3) and (Byte(FData[0][1]) = AE_LOOPING);
end;
procedure FreeExtensions(Extensions: TList); {near;}
begin
if Extensions <> nil then
begin
while Extensions.Count > 0 do
begin
TObject(Extensions[0]).Free;
Extensions.Delete(0);
end;
Extensions.Free;
end;
end;
function FindExtension(Extensions: TList; ExtType: TExtensionType): TExtension;
var
I: Integer;
begin
if Extensions <> nil then
for I := Extensions.Count - 1 downto 0 do
begin
Result := TExtension(Extensions[I]);
if (Result <> nil) and (Result.FExtType = ExtType) then
Exit;
end;
Result := nil;
end;
{
function CopyExtensions(Source: TList): TList; near;
var
I: Integer;
Ext: TExtension;
begin
Result := TList.Create;
try
for I := 0 to Source.Count - 1 do
if (Source[I] <> nil) and (TObject(Source[I]) is TExtension) then
begin
Ext := TExtension.Create;
try
Ext.Assign(Source[I]);
Result.Add(Ext);
except
Ext.Free;
raise;
end;
end;
except
Result.Free;
raise;
end;
end;
}
type
TProgressProc = procedure(Stage: TProgressStage; PercentDone: Byte;
const Msg: string) of object;
{ GIF reading/writing routines
Procedures to read and write GIF files, GIF-decoding and encoding
based on freeware C source code of GBM package by Andy Key
(nyangau att interalpha dott co dott 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 = {%H-}^TReadContext;
TReadContext = record
Inx: Longint;
Size: Longint;
Buf: array [0..255 + 4] of Byte;
CodeSize: Longint;
ReadMask: Longint;
end;
PWriteContext = {%H-}^TWriteContext;
TWriteContext = record
Inx: Longint;
CodeSize: Longint;
Buf: array [0..255 + 4] of Byte;
end;
TOutputContext = record
W: Longint;
H: Longint;
X: Longint;
Y: Longint;
BitsPerPixel: Integer;
Pass: Integer;
Interlace: Boolean;
LineIdent: Longint;
Data: Pointer;
CurrLineData: Pointer;
end;
PImageDict = ^TImageDict;
TImageDict = record
Tail: Word;
Index: Word;
Col: Byte;
end;
PDictTable = ^TDictTable;
TDictTable = array [0..CODE_TABLE_SIZE - 1] of TImageDict;
function InitHash(P: Longint): Longint;
begin
Result := (P + 3) * 301;
end;
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, Dest: TStream; var Desc: TImageDescriptor;
var Interlaced, LocalColors, Corrupted: Boolean; var BitsPerPixel: Byte;
var ColorTable: TGIFColorTable);
var
CodeSize: Byte = 0;
BlockSize: Byte = 0;
begin
Corrupted := False;
Stream.ReadBuffer(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.Count := 1 shl BitsPerPixel;
Stream.ReadBuffer(ColorTable.Colors[0],
ColorTable.Count * SizeOf(TGIFColorItem));
end
else
begin
LocalColors := False;
FillChar(ColorTable, SizeOf(ColorTable), 0);
end;
Stream.ReadBuffer(CodeSize, 1);
Dest.Write(CodeSize, 1);
repeat
Stream.Read(BlockSize, 1);
if (Stream.Position + BlockSize) > Stream.Size then
begin
Corrupted := True;
Stream.Position := Stream.Size;
Exit;
end;
Dest.Write(BlockSize, 1);
if (Stream.Position + BlockSize) > Stream.Size then
begin
BlockSize := Stream.Size - Stream.Position;
Corrupted := True;
end;
if BlockSize > 0 then
Dest.CopyFrom(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.Count - 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: TStream; var Context: TReadContext): Longint;
var
RawCode: Longint;
ByteIndex: Longint;
Bytes: Byte = 0;
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.ReadBuffer(Bytes, 1);
if Bytes > 0 then
Stream.ReadBuffer(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 := PByte(PAnsiChar(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 := PByte(PAnsiChar(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 := PByte(PAnsiChar(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 := PAnsiChar(Context.Data) + (Context.H - 1 - Context.Y) * Context.LineIdent;
end;
procedure ReadGIFData(Stream: TStream; const Header: TBitmapInfoHeader;
Interlaced, LoadCorrupt: Boolean; IntBitPerPixel: Byte; Data: Pointer;
var Corrupted: Boolean; ProgressProc: TProgressProc);
var
MinCodeSize: Byte = 0;
Temp: 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
if Assigned(ProgressProc) then
ProgressProc(psStarting, 0, '');
try
Stream.ReadBuffer(MinCodeSize, 1);
if (MinCodeSize < 2) or (MinCodeSize > 9) then
begin
if LoadCorrupt then
begin
Corrupted := True;
MinCodeSize := Max(2, Min(MinCodeSize, 9));
end
else
GifError(RsEBadGIFCodeSize);
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 := PAnsiChar(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(RsEGIFDecodeError);
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);
if Stream.Size > 0 then
begin
Temp := Trunc(100.0 * (Stream.Position / Stream.Size));
if Assigned(ProgressProc) then
ProgressProc(psRunning, Temp, '');
end;
end; { while }
if Code = $FFFF then
GifError(SReadError);
finally
if Assigned(ProgressProc) then
begin
if ExceptObject = nil then
ProgressProc(psEnding, 100, '')
else
ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
end;
end;
finally
FreeMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
end;
finally
FreeMem(Suffix, SizeOf(TIntCodeTable));
end;
finally
FreeMem(Prefix, SizeOf(TIntCodeTable));
end;
end;
procedure WriteCode(Stream: TStream; Code: Longint;
var Context: TWriteContext);
var
BufIndex: Longint;
Bytes: Byte;
begin
BufIndex := Context.Inx shr 3;
Code := Code shl (Context.Inx and 7);
Context.Buf[BufIndex] := Context.Buf[BufIndex] or Code;
Context.Buf[BufIndex + 1] := (Code shr 8);
Context.Buf[BufIndex + 2] := (Code shr 16);
Context.Inx := Context.Inx + Context.CodeSize;
if Context.Inx >= 255 * 8 then
begin
{ Flush out full buffer }
Bytes := 255;
Stream.WriteBuffer(Bytes, 1);
Stream.WriteBuffer(Context.Buf, Bytes);
Move(Context.Buf[255], Context.Buf[0], 2);
FillChar(Context.Buf[2], 255, 0);
Context.Inx := Context.Inx - (255 * 8);
end;
end;
procedure FlushCode(Stream: TStream; var Context: TWriteContext);
var
Bytes: Byte;
begin
Bytes := (Context.Inx + 7) shr 3;
if Bytes > 0 then
begin
Stream.WriteBuffer(Bytes, 1);
Stream.WriteBuffer(Context.Buf, Bytes);
end;
{ Data block terminator - a block of zero Size }
Bytes := 0;
Stream.WriteBuffer(Bytes, 1);
end;
procedure FillColorTable(var ColorTable: TGIFColorTable;
const Colors: TRGBPalette; Count: Integer);
var
I: Byte;
begin
FillChar(ColorTable, SizeOf(ColorTable), 0);
ColorTable.Count := Min(256, Count);
for I := 0 to ColorTable.Count - 1 do
begin
ColorTable.Colors[I].Red := Colors[I].rgbRed;
ColorTable.Colors[I].Green := Colors[I].rgbGreen;
ColorTable.Colors[I].Blue := Colors[I].rgbBlue;
end;
end;
procedure WriteGIFData(Stream: TStream; var Header: TBitmapInfoHeader;
Interlaced: Boolean; Data: Pointer; ProgressProc: TProgressProc);
{ LZW encode data }
var
LineIdent: Longint;
MinCodeSize, Col, Temp: Byte;
InitCodeSize, X, Y: Longint;
Pass: Integer;
MaxCode: Longint; { 1 shl CodeSize }
ClearCode, EndingCode, LastCode, Tail: Longint;
I, HashValue: Longint;
LenString: Word;
Dict: PDictTable;
HashTable: TList;
PData: PByte;
WriteCtxt: TWriteContext;
begin
LineIdent := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
Tail := 0;
HashValue := 0;
Dict := AllocMem(SizeOf(TDictTable));
try
HashTable := TList.Create;
try
for I := 0 to HASH_TABLE_SIZE - 1 do
HashTable.Add(nil);
{ Initialise encoder variables }
InitCodeSize := Header.biBitCount + 1;
if InitCodeSize = 2 then
Inc(InitCodeSize);
MinCodeSize := InitCodeSize - 1;
Stream.WriteBuffer(MinCodeSize, 1);
ClearCode := 1 shl MinCodeSize;
EndingCode := ClearCode + 1;
LastCode := EndingCode;
MaxCode := 1 shl InitCodeSize;
LenString := 0;
{ Setup write context }
WriteCtxt.Inx := 0;
WriteCtxt.CodeSize := InitCodeSize;
FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
WriteCode(Stream, ClearCode, WriteCtxt);
for I := 0 to HASH_TABLE_SIZE - 1 do
HashTable[I] := nil;
Data := PAnsiChar(Data) + (Header.biHeight - 1) * LineIdent;
Y := 0;
Pass := 0;
if Assigned(ProgressProc) then
ProgressProc(psStarting, 0, '');
try
while Y < Header.biHeight do
begin
PData := PByte(PAnsiChar(Data) - (Y * LineIdent));
for X := 0 to Header.biWidth - 1 do
begin
case Header.biBitCount of
8:
begin
Col := PData^;
Inc(PData);
end;
4:
begin
if X and 1 <> 0 then
begin
Col := PData^ and $0F;
Inc(PData);
end
else
Col := PData^ shr 4;
end;
else { must be 1 }
begin
if X and 7 = 7 then
begin
Col := PData^ and 1;
Inc(PData);
end
else
Col := (PData^ shr (7 - (X and $07))) and $01;
end;
end;
Inc(LenString);
if LenString = 1 then
begin
Tail := Col;
HashValue := InitHash(Col);
end
else
begin
HashValue := HashValue * (Col + LenString + 4);
I := HashValue mod HASH_TABLE_SIZE;
HashValue := HashValue mod HASH_TABLE_SIZE;
while (HashTable[I] <> nil) and
((PImageDict(HashTable[I])^.Tail <> Tail) or
(PImageDict(HashTable[I])^.Col <> Col)) do
begin
Inc(I);
if I >= HASH_TABLE_SIZE then
I := 0;
end;
if HashTable[I] <> nil then { Found in the strings table }
Tail := PImageDict(HashTable[I])^.Index
else
begin
{ Not found }
WriteCode(Stream, Tail, WriteCtxt);
Inc(LastCode);
HashTable[I] := @Dict^[LastCode];
PImageDict(HashTable[I])^.Index := LastCode;
PImageDict(HashTable[I])^.Tail := Tail;
PImageDict(HashTable[I])^.Col := Col;
Tail := Col;
HashValue := InitHash(Col);
LenString := 1;
if LastCode >= MaxCode then
begin
{ Next Code will be written longer }
MaxCode := MaxCode shl 1;
Inc(WriteCtxt.CodeSize);
end
else
if LastCode >= CODE_TABLE_SIZE - 2 then
begin
{ Reset tables }
WriteCode(Stream, Tail, WriteCtxt);
WriteCode(Stream, ClearCode, WriteCtxt);
LenString := 0;
LastCode := EndingCode;
WriteCtxt.CodeSize := InitCodeSize;
MaxCode := 1 shl InitCodeSize;
for I := 0 to HASH_TABLE_SIZE - 1 do
HashTable[I] := nil;
end;
end;
end;
end; { for X loop }
if Interlaced then
Y := InterlaceStep(Y, Header.biHeight, Pass)
else
Inc(Y);
Temp := Trunc(100.0 * (Y / Header.biHeight));
if Assigned(ProgressProc) then
ProgressProc(psRunning, Temp, '');
end; { while Y loop }
WriteCode(Stream, Tail, WriteCtxt);
WriteCode(Stream, EndingCode, WriteCtxt);
FlushCode(Stream, WriteCtxt);
finally
if Assigned(ProgressProc) then
begin
if ExceptObject = nil then
ProgressProc(psEnding, 100, '')
else
ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
end;
end;
finally
HashTable.Free;
end;
finally
FreeMem(Dict, SizeOf(TDictTable));
end;
end;
//=== { TGIFItem } ===========================================================
destructor TGIFItem.Destroy;
begin
FImageData.Free;
inherited Destroy;
end;
procedure TGIFItem.FreeHandle;
begin
if FImageData <> nil then
FImageData.SetSize(0);
end;
//=== { TGIFData } ===========================================================
constructor TGIFData.Create;
begin
inherited Create;
FComment := TStringList.Create;
end;
destructor TGIFData.Destroy;
begin
FComment.Free;
inherited Destroy;
end;
procedure TGIFData.FreeHandle;
begin
if FComment <> nil then
FComment.Clear;
end;
//=== { TJvGIFFrame } ========================================================
constructor TJvGIFFrame.Create(AOwner: TJvGIFImage);
begin
FOwner := AOwner;
inherited Create;
NewImage;
end;
destructor TJvGIFFrame.Destroy;
begin
FBitmap.Free;
FreeExtensions(FExtensions);
FImage.Release;
inherited Destroy;
end;
procedure TJvGIFFrame.SetAnimateInterval(Value: Word);
begin
if FAnimateInterval <> Value then
begin
FAnimateInterval := Value;
if Value > 0 then
FOwner.FVersion := gv89a;
FOwner.Changed(FOwner);
end;
end;
procedure TJvGIFFrame.SetDisposalMethod(Value: TDisposalMethod);
begin
if FDisposal <> Value then
begin
FDisposal := Value;
if Value <> dmUndefined then
FOwner.FVersion := gv89a;
FOwner.Changed(FOwner);
end;
end;
procedure TJvGIFFrame.SetTopLeft(const Value: TPoint);
begin
if (FTopLeft.X <> Value.X) or (FTopLeft.Y <> Value.Y) then
begin
FTopLeft.X := Value.X;
FTopLeft.Y := Value.Y;
FOwner.FScreenWidth := Max(FOwner.FScreenWidth,
FImage.FSize.X + FTopLeft.X);
FOwner.FScreenHeight := Max(FOwner.FScreenHeight,
FImage.FSize.Y + FTopLeft.Y);
FOwner.Changed(FOwner);
end;
end;
procedure TJvGIFFrame.SetTransparentColor(Value: TColor);
begin
if FTransparentColor <> Value then
begin
FTransparentColor := Value;
if Value <> clNone then
FOwner.FVersion := gv89a;
FOwner.Changed(FOwner);
end;
end;
function TJvGIFFrame.GetBitmap: TBitmap;
var
Mem: TMemoryStream;
begin
Result := FBitmap;
if (Result = nil) or Result.Empty then
begin
NewBitmap;
Result := FBitmap;
if Assigned(FImage.FImageData) then
try
Mem := TMemoryStream.Create;
try
SaveToBitmapStream(Mem);
FBitmap.LoadFromStream(Mem);
if not FBitmap.Monochrome then
FBitmap.HandleType := bmDDB;
finally
Mem.Free;
end;
except
raise;
end;
end;
end;
function TJvGIFFrame.GetHeight: Integer;
begin
if Assigned(FBitmap) or Assigned(FImage.FImageData) then
Result := Bitmap.Height
else
Result := 0;
end;
function TJvGIFFrame.GetWidth: Integer;
begin
if Assigned(FBitmap) or Assigned(FImage.FImageData) then
Result := Bitmap.Width
else
Result := 0;
end;
function TJvGIFFrame.GetColorCount: Integer;
begin
Result := FImage.FColorMap.Count;
if (Result = 0) and Assigned(FBitmap) and (FBitmap.Palette <> 0) then
Result := PaletteEntries(FBitmap.Palette);
end;
procedure TJvGIFFrame.GrayscaleImage(ForceEncoding: Boolean);
var
Mem: TMemoryStream;
TransIndex: Integer;
begin
if not FGrayscale and (Assigned(FBitmap) or
Assigned(FImage.FImageData)) then
begin
if Assigned(FImage.FImageData) and (FImage.FColorMap.Count > 0) then
begin
FBitmap.Free;
FBitmap := nil;
TransIndex := FindColorIndex(FImage.FColorMap, FTransparentColor);
GrayColorTable(FImage.FColorMap);
if TransIndex >= 0 then
FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex])
else
FTransparentColor := clNone;
FGrayscale := True;
try
GetBitmap;
except
on EAbort do
;
else
raise;
end;
end
else
begin
Mem := BitmapToMemoryStream(Bitmap, pf8bit, mmGrayscale);
try
FImage.Release;
FImage := TGIFItem.Create;
FImage.Reference;
if ForceEncoding then
EncodeBitmapStream(Mem);
FGrayscale := True;
if FTransparentColor <> clNone then
FTransparentColor := GrayColor(FTransparentColor);
FBitmap.LoadFromStream(Mem);
finally
Mem.Free;
end;
end;
end;
end;
procedure TJvGIFFrame.Assign(Source: TPersistent);
var
AComment: TStrings;
begin
if Source = nil then
begin
NewImage;
FBitmap.Free;
FBitmap := nil;
end
else
if Source is TJvGIFFrame then
begin
if Source <> Self then
begin
FImage.Release;
FImage := TJvGIFFrame(Source).FImage;
if TJvGIFFrame(Source).FOwner <> FOwner then
FLocalColors := True
else
FLocalColors := TJvGIFFrame(Source).FLocalColors;
FImage.Reference;
FTopLeft := TJvGIFFrame(Source).FTopLeft;
FInterlaced := TJvGIFFrame(Source).FInterlaced;
if TJvGIFFrame(Source).FBitmap <> nil then
begin
NewBitmap;
FBitmap.Assign(TJvGIFFrame(Source).FBitmap);
end;
FTransparentColor := TJvGIFFrame(Source).FTransparentColor;
FAnimateInterval := TJvGIFFrame(Source).FAnimateInterval;
FDisposal := TJvGIFFrame(Source).FDisposal;
FGrayscale := TJvGIFFrame(Source).FGrayscale;
FCorrupted := TJvGIFFrame(Source).FCorrupted;
AComment := TJvGIFFrame(Source).FindComment(False);
if (AComment <> nil) and (AComment.Count > 0) then
SetComment(AComment);
end;
end
else
if Source is TJvGIFImage then
begin
if TJvGIFImage(Source).Count > 0 then
begin
if TJvGIFImage(Source).FrameIndex >= 0 then
Assign(TJvGIFImage(Source).Frames[TJvGIFImage(Source).FrameIndex])
else
Assign(TJvGIFImage(Source).Frames[0]);
end
else
Assign(nil);
end
else
if Source is TGraphic then
begin
{ TBitmap, TJPEGImage... }
if TGraphic(Source).Empty then
begin
Assign(nil);
Exit;
end;
NewImage;
NewBitmap;
try
FBitmap.Assign(Source);
if Source is TBitmap then
FBitmap.Monochrome := TBitmap(Source).Monochrome;
except
FBitmap.Canvas.Brush.Color := clFuchsia;
FBitmap.Width := TGraphic(Source).Width;
FBitmap.Height := TGraphic(Source).Height;
FBitmap.Canvas.Draw(0, 0, TGraphic(Source));
end;
if TGraphic(Source).Transparent then
begin
if Source is TBitmap then
FTransparentColor := TBitmap(Source).TransparentColor
else
FTransparentColor := GetNearestColor(FBitmap.Canvas.Handle,
ColorToRGB(FBitmap.Canvas.Brush.Color));
end;
end
else
inherited Assign(Source);
if FOwner <> nil then
FOwner.UpdateScreenSize;
end;
procedure TJvGIFFrame.AssignTo(Dest: TPersistent);
begin
if (Dest is TJvGIFFrame) or (Dest is TJvGIFImage) then
Dest.Assign(Self)
else
if Dest is TGraphic then
begin
Dest.Assign(Bitmap);
if (Dest is TBitmap) and (FTransparentColor <> clNone) then
begin
TBitmap(Dest).TransparentColor := GetNearestColor(
TBitmap(Dest).Canvas.Handle, ColorToRGB(FTransparentColor));
TBitmap(Dest).Transparent := True;
end;
end
else
inherited AssignTo(Dest);
end;
procedure TJvGIFFrame.NewBitmap;
begin
FBitmap.Free;
FBitmap := TBitmap.Create;
end;
procedure TJvGIFFrame.NewImage;
begin
if FImage <> nil then
FImage.Release;
FImage := TGIFItem.Create;
FImage.Reference;
FGrayscale := False;
FCorrupted := False;
FTransparentColor := clNone;
FTopLeft := Point(0, 0);
FInterlaced := False;
FLocalColors := False;
FAnimateInterval := 0;
FDisposal := dmUndefined;
end;
function TJvGIFFrame.FindComment(ForceCreate: Boolean): TStrings;
var
Ext: TExtension;
begin
Ext := FindExtension(FExtensions, etComment);
if (Ext = nil) and ForceCreate then
begin
Ext := TExtension.Create;
try
Ext.FExtType := etComment;
if FExtensions = nil then
FExtensions := TList.Create;
FExtensions.Add(Ext);
except
Ext.Free;
raise;
end;
end;
if Ext <> nil then
begin
if (Ext.FData = nil) and ForceCreate then
Ext.FData := TStringList.Create;
Result := Ext.FData;
end
else
Result := nil;
end;
function TJvGIFFrame.GetComment: TStrings;
begin
Result := FindComment(True);
end;
procedure TJvGIFFrame.SetComment(Value: TStrings);
begin
GetComment.Assign(Value);
end;
procedure TJvGIFFrame.UpdateExtensions;
var
Ext: TExtension;
I: Integer;
begin
Ext := FindExtension(FExtensions, etGraphic);
if (FAnimateInterval > 0) or (FTransparentColor <> clNone) or
(FDisposal <> dmUndefined) then
begin
if Ext = nil then
begin
Ext := TExtension.Create;
Ext.FExtType := etGraphic;
if FExtensions = nil then
FExtensions := TList.Create;
FExtensions.Add(Ext);
with Ext.FExtRec.GCE do
begin
BlockSize := 4;
PackedFields := 0;
Terminator := 0;
end;
end;
end;
if Ext <> nil then
with Ext.FExtRec.GCE do
begin
DelayTime := FAnimateInterval div 10;
I := FindColorIndex(FImage.FColorMap, FTransparentColor);
if I >= 0 then
begin
TransparentColorIndex := I;
PackedFields := PackedFields or GCE_TRANSPARENT;
end
else
PackedFields := PackedFields and not GCE_TRANSPARENT;
PackedFields := (PackedFields and not GCE_DISPOSAL_METHOD) or
(Ord(FDisposal) shl 2);
end;
if FExtensions <> nil then
for I := FExtensions.Count - 1 downto 0 do
begin
Ext := TExtension(FExtensions[I]);
if (Ext <> nil) and (Ext.FExtType = etComment) and
((Ext.FData = nil) or (Ext.FData.Count = 0)) then
begin
Ext.Free;
FExtensions.Delete(I);
end;
end;
if (FExtensions <> nil) and (FExtensions.Count > 0) then
FOwner.FVersion := gv89a;
end;
procedure TJvGIFFrame.EncodeBitmapStream(Stream: TMemoryStream);
var
BI: PBitmapInfoHeader;
lColorCount, W, H: Integer;
Bits, Pal: Pointer;
begin
lColorCount := 0;
Stream.Position := 0;
BI := PBitmapInfoHeader(PAnsiChar(Stream.Memory) + SizeOf(TBitmapFileHeader));
W := BI^.biWidth;
H := BI^.biHeight;
Pal := PRGBPalette(PAnsiChar(BI) + SizeOf(TBitmapInfoHeader));
Bits := Pointer(PAnsiChar(Stream.Memory) + PBitmapFileHeader(Stream.Memory)^.bfOffBits);
case BI^.biBitCount of
1:
lColorCount := 2;
4:
lColorCount := 16;
8:
lColorCount := 256;
else
GifError(RsEGIFEncodeError);
end;
FInterlaced := False;
FillColorTable(FImage.FColorMap, PRGBPalette(Pal)^, lColorCount);
if FImage.FImageData = nil then
FImage.FImageData := TMemoryStream.Create
else
FImage.FImageData.SetSize(0);
try
WriteGIFData(FImage.FImageData, BI^, FInterlaced, Bits, @FOwner.DoProgress);
except
on EAbort do
begin
NewImage; { OnProgress can raise EAbort to cancel image save }
raise;
end
else
raise;
end;
FImage.FBitsPerPixel := 1;
while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
Inc(FImage.FBitsPerPixel);
if FOwner.FImage.FColorMap.Count = 0 then
begin
FOwner.FImage.FColorMap := FImage.FColorMap;
FOwner.FImage.FBitsPerPixel := FImage.FBitsPerPixel;
FLocalColors := False;
end
else
FLocalColors := True;
FImage.FSize.X := W;
FImage.FSize.Y := H;
FOwner.FScreenWidth := Max(FOwner.FScreenWidth, FImage.FSize.X + FTopLeft.X);
FOwner.FScreenHeight := Max(FOwner.FScreenHeight, FImage.FSize.Y + FTopLeft.Y);
end;
procedure TJvGIFFrame.EncodeRasterData;
var
Method: TMappingMethod;
Mem: TMemoryStream;
begin
if not Assigned(FBitmap) or FBitmap.Empty then
GifError(RsENoGIFData);
if not (GetBitmapPixelFormat(FBitmap) in [pf1bit, pf4bit, pf8bit]) then
begin
if FGrayscale then
Method := mmGrayscale
else
Method := DefaultMappingMethod;
Mem := BitmapToMemoryStream(FBitmap, pf8bit, Method);
if Method = mmGrayscale then
FGrayscale := True;
end
else
Mem := TMemoryStream.Create;
try
if Mem.Size = 0 then
FBitmap.SaveToStream(Mem);
EncodeBitmapStream(Mem);
finally
Mem.Free;
end;
end;
procedure TJvGIFFrame.WriteImageDescriptor(Stream: TStream);
var
ImageDesc: TImageDescriptor;
begin
with ImageDesc do
begin
PackedFields := 0;
if FLocalColors then
begin
FImage.FBitsPerPixel := 1;
while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
Inc(FImage.FBitsPerPixel);
PackedFields := (PackedFields or ID_LOCAL_COLOR_TABLE) +
(FImage.FBitsPerPixel - 1);
end;
if FInterlaced then
PackedFields := PackedFields or ID_INTERLACED;
ImageLeftPos := FTopLeft.X;
ImageTopPos := FTopLeft.Y;
ImageWidth := FImage.FSize.X;
ImageHeight := FImage.FSize.Y;
end;
Stream.Write(ImageDesc, SizeOf(TImageDescriptor));
end;
procedure TJvGIFFrame.WriteLocalColorMap(Stream: TStream);
begin
if FLocalColors then
with FImage.FColorMap do
Stream.Write(Colors[0], Count * SizeOf(TGIFColorItem));
end;
procedure TJvGIFFrame.WriteRasterData(Stream: TStream);
begin
Stream.WriteBuffer(FImage.FImageData.Memory^, FImage.FImageData.Size);
end;
procedure TJvGIFFrame.SaveToBitmapStream(Stream: TMemoryStream);
function ConvertBitsPerPixel: TPixelFormat;
begin
Result := pfDevice;
case FImage.FBitsPerPixel of
1:
Result := pf1bit;
2..4:
Result := pf4bit;
5..8:
Result := pf8bit;
else
GifError(RsEWrongGIFColors);
end;
end;
var
HeaderSize: Longword;
Length: Longword;
BI: TBitmapInfoHeader;
BitFile: TBitmapFileHeader;
Colors: TRGBPalette;
Bits: Pointer;
Corrupt: Boolean = false;
begin
with BI do
begin
biSize := SizeOf(TBitmapInfoHeader);
biWidth := FImage.FSize.X;
biHeight := FImage.FSize.Y;
biPlanes := 1;
biBitCount := 0;
case ConvertBitsPerPixel of
pf1bit:
biBitCount := 1;
pf4bit:
biBitCount := 4;
pf8bit:
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 BI.biBitCount);
Length := HeaderSize + BI.biSizeImage;
Stream.SetSize(0);
Stream.Position := 0;
with BitFile do
begin
bfType := $4D42; { BM }
bfSize := Length;
bfOffBits := HeaderSize;
end;
Stream.Write(BitFile, SizeOf(TBitmapFileHeader));
Stream.Write(BI, SizeOf(TBitmapInfoHeader));
Colors := Default(TRGBPalette);
FillRGBPalette(FImage.FColorMap, Colors);
Stream.Write(Colors, SizeOf(TRGBQuad) * (1 shl BI.biBitCount));
// Bits := GlobalAllocPtr(GMEM_ZEROINIT, BI.biSizeImage); // not in LCL
Bits := AllocMem(BI.biSizeImage);
try
FImage.FImageData.Position := 0;
ReadGIFData(FImage.FImageData, BI, FInterlaced, GIFLoadCorrupted,
FImage.FBitsPerPixel, Bits, Corrupt, @FOwner.DoProgress);
FCorrupted := FCorrupted or Corrupt;
Stream.WriteBuffer(Bits^, BI.biSizeImage);
finally
//GlobalFreePtr(Bits); // Not in LCL
FreeMem(Bits);
end;
Stream.Position := 0;
end;
function ColorItemTwiceInColorMap(Index: Integer; ColorMap: TGIFColorTable): Boolean;
var
I: Integer;
begin
Result := False;
I := 0;
while (I < ColorMap.Count) and not Result do
begin
if (I = Index) then
begin
Inc(I);
end
else
begin
Result := (ItemToRGB(ColorMap.Colors[Index]) = ItemToRGB(ColorMap.Colors[I]));
end;
Inc(I);
end;
end;
procedure TJvGIFFrame.LoadFromStream(Stream: TStream);
var
ImageDesc: TImageDescriptor;
I, Offset, TransIndex: Integer;
begin
FImage.FImageData := TMemoryStream.Create;
try
ImageDesc := Default(TImageDescriptor);
ReadImageStream(Stream, FImage.FImageData, ImageDesc, FInterlaced,
FLocalColors, FCorrupted, FImage.FBitsPerPixel, FImage.FColorMap);
if FCorrupted and not GIFLoadCorrupted then
GifError(SReadError);
FImage.FImageData.Position := 0;
with ImageDesc do
begin
if ImageHeight = 0 then
ImageHeight := FOwner.FScreenHeight;
if ImageWidth = 0 then
ImageWidth := FOwner.FScreenWidth;
FTopLeft := Point(ImageLeftPos, ImageTopPos);
FImage.FSize := Point(ImageWidth, ImageHeight);
FImage.FPackedFields := PackedFields;
end;
if not FLocalColors then
FImage.FColorMap := FOwner.FImage.FColorMap;
FAnimateInterval := 0;
if FExtensions <> nil then
begin
for I := 0 to FExtensions.Count - 1 do
with TExtension(FExtensions[I]) do
if FExtType = etGraphic then
begin
if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then
begin
TransIndex := FExtRec.GCE.TransparentColorIndex;
if FImage.FColorMap.Count > TransIndex then
begin
// Mantis 2135: Ensure that the transparent color does not appear
// twice in the palette or the second color index would end up
// being transparent as well
Offset := -1;
while ColorItemTwiceInColorMap(TransIndex, FImage.FColorMap) do
begin
if FImage.FColorMap.Colors[TransIndex].Blue = 0 then
Offset := 1
else
if FImage.FColorMap.Colors[TransIndex].Blue = 255 then
Offset := -1;
Inc(FImage.FColorMap.Colors[TransIndex].Blue, Offset);
end;
FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex]);
end;
end
else
FTransparentColor := clNone;
FAnimateInterval := Max(FExtRec.GCE.DelayTime * 10, FAnimateInterval);
FDisposal := TDisposalMethod((FExtRec.GCE.PackedFields and GCE_DISPOSAL_METHOD) shr 2);
end;
end;
except
FImage.FImageData.Free;
FImage.FImageData := nil;
raise;
end;
end;
procedure TJvGIFFrame.Draw(ACanvas: TCanvas; const ARect: TRect;
Transparent: Boolean);
begin
if (FTransparentColor <> clNone) and Transparent then
begin
StretchBitmapRectTransparent(ACanvas, ARect.Left, ARect.Top, ARect.Right - ARect.Left,
ARect.Bottom - ARect.Top, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap,
FTransparentColor);
end
else
ACanvas.StretchDraw(ARect, Bitmap);
end;
//=== { TJvGIFImage } ========================================================
constructor TJvGIFImage.Create;
begin
inherited Create;
NewImage;
FTransparent := true;
end;
destructor TJvGIFImage.Destroy;
begin
OnChange := nil;
FImage.Release;
ClearItems;
FItems.Free;
inherited Destroy;
end;
procedure TJvGIFImage.Clear;
begin
Assign(nil);
end;
procedure TJvGIFImage.ClearItems;
begin
if FItems <> nil then
while FItems.Count > 0 do
begin
TObject(FItems[0]).Free;
FItems.Delete(0);
end;
end;
procedure TJvGIFImage.Assign(Source: TPersistent);
var
I: Integer;
AFrame: TJvGIFFrame;
begin
if Source = nil then
begin
NewImage;
Changed(Self);
end
else
if (Source is TJvGIFImage) and (Source <> Self) then
begin
FImage.Release;
FImage := TJvGIFImage(Source).FImage;
FImage.Reference;
FVersion := TJvGIFImage(Source).FVersion;
FBackgroundColor := TJvGIFImage(Source).FBackgroundColor;
FRepeatCount := TJvGIFImage(Source).FRepeatCount;
FLooping := TJvGIFImage(Source).FLooping;
FCorrupted := TJvGIFImage(Source).FCorrupted;
if FItems = nil then
FItems := TList.Create
else
ClearItems;
with TJvGIFImage(Source) do
begin
for I := 0 to FItems.Count - 1 do
begin
AFrame := TJvGIFFrame.Create(Self);
try
AFrame.FImage.FBitsPerPixel :=
TJvGIFFrame(FItems[I]).FImage.FBitsPerPixel;
AFrame.Assign(TJvGIFFrame(FItems[I]));
AFrame.FLocalColors := TJvGIFFrame(FItems[I]).FLocalColors;
Self.FItems.Add(AFrame);
except
AFrame.Free;
raise;
end;
end;
Self.FScreenWidth := FScreenWidth;
Self.FScreenHeight := FScreenHeight;
end;
FFrameIndex := TJvGIFImage(Source).FFrameIndex;
Changed(Self);
end
else
if Source is TJvGIFFrame then
begin
NewImage;
with TJvGIFFrame(Source).FOwner.FImage do
begin
FImage.FAspectRatio := FAspectRatio;
FImage.FBitsPerPixel := FBitsPerPixel;
FImage.FColorResBits := FColorResBits;
Move(FColorMap, FImage.FColorMap, SizeOf(FColorMap));
end;
FFrameIndex := FItems.Add(TJvGIFFrame.Create(Self));
TJvGIFFrame(FItems[FFrameIndex]).Assign(Source);
if FVersion = gvUnknown then
FVersion := gv87a;
Changed(Self);
end
else
if Source is TBitmap then
begin
NewImage;
AddFrame(TBitmap(Source));
Changed(Self);
end
(****************** NOT CONVERTED
else
if Source is TJvAni then
begin
NewImage;
FBackgroundColor := clWindow;
with TJvAni(Source) do
begin
for I := 0 to FrameCount - 1 do
begin
AddFrame(TIcon(Icons[I]));
Self.Frames[I].FAnimateInterval := Longint(Frames[I].Rate * 100) div 6;
if Frames[I].Rate = 0 then
Self.Frames[I].FAnimateInterval := 100;
end;
end;
Changed(Self);
end
*************************)
else
inherited Assign(Source);
end;
procedure TJvGIFImage.AssignTo(Dest: TPersistent);
begin
if Dest is TJvGIFImage then
Dest.Assign(Self)
else
if Dest is TGraphic then
begin
if Empty then
Dest.Assign(nil)
else
if FFrameIndex >= 0 then
TJvGIFFrame(FItems[FFrameIndex]).AssignTo(Dest)
else
Dest.Assign(Bitmap);
end
else
inherited AssignTo(Dest);
end;
procedure TJvGIFImage.Draw(ACanvas: TCanvas; const ARect: TRect);
begin
if FFrameIndex >= 0 then
TJvGIFFrame(FItems[FFrameIndex]).Draw(ACanvas, ARect, Self.Transparent);
end;
function TJvGIFImage.GetBackgroundColor: TColor;
begin
Result := FBackgroundColor;
end;
procedure TJvGIFImage.SetBackgroundColor(Value: TColor);
begin
if Value <> FBackgroundColor then
begin
FBackgroundColor := Value;
Changed(Self);
end;
end;
procedure TJvGIFImage.SetLooping(Value: Boolean);
begin
if Value <> FLooping then
begin
FLooping := Value;
Changed(Self);
end;
end;
procedure TJvGIFImage.SetRepeatCount(Value: Word);
begin
if Min(Value, MAX_LOOP_COUNT) <> FRepeatCount then
begin
FRepeatCount := Min(Value, MAX_LOOP_COUNT);
Changed(Self);
end;
end;
function TJvGIFImage.GetPixelFormat: TPixelFormat;
var
I: Integer;
begin
Result := pfDevice;
if not Empty then
begin
Result := ColorsToPixelFormat(FImage.FColorMap.Count);
for I := 0 to FItems.Count - 1 do
begin
if (Frames[I].FImage.FImageData = nil) or
(Frames[I].FImage.FImageData.Size = 0) then
begin
if Assigned(Frames[I].FBitmap) then
Result := TPixelFormat(Max(Ord(Result),
Ord(GetBitmapPixelFormat(Frames[I].FBitmap))))
else
Result := TPixelFormat(Max(Ord(Result), Ord(pfDevice)));
end
else
if Frames[I].FLocalColors then
Result := TPixelFormat(Max(Ord(Result),
Ord(ColorsToPixelFormat(Frames[I].FImage.FColorMap.Count))));
end;
end;
end;
function TJvGIFImage.GetCorrupted: Boolean;
var
I: Integer;
begin
Result := FCorrupted;
if not Result then
for I := 0 to FItems.Count - 1 do
if Frames[I].Corrupted then
begin
Result := True;
Exit;
end;
end;
function TJvGIFImage.GetTransparentColor: TColor;
begin
if (FItems.Count > 0) and (FFrameIndex >= 0) then
Result := TJvGIFFrame(FItems[FFrameIndex]).FTransparentColor
else
Result := clNone;
end;
function TJvGIFImage.GetCount: Integer;
begin
Result := FItems.Count;
end;
function TJvGIFImage.GetFrame(Index: Integer): TJvGIFFrame;
begin
Result := TJvGIFFrame(FItems[Index]);
end;
procedure TJvGIFImage.SetFrameIndex(Value: Integer);
begin
Value := Min(FItems.Count - 1, Max(-1, Value));
if FFrameIndex <> Value then
begin
FFrameIndex := Value;
PaletteModified := True;
Changed(Self);
end;
end;
function TJvGIFImage.Equals(Graphic: TGraphic): Boolean;
begin
Result := (Graphic is TJvGIFImage) and
(FImage = TJvGIFImage(Graphic).FImage);
end;
function TJvGIFImage.GetBitmap: TBitmap;
var
Bmp: TBitmap;
begin
if FItems.Count > 0 then
begin
if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap
else
Result := TJvGIFFrame(FItems[0]).Bitmap
end
else
begin
FFrameIndex := 0;
Bmp := TBitmap.Create;
try
Bmp.Handle := 0;
Assign(Bmp);
Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap;
finally
Bmp.Free;
end;
end;
end;
function TJvGIFImage.GetGlobalColorCount: Integer;
begin
Result := FImage.FColorMap.Count;
end;
function TJvGIFImage.GetEmpty: Boolean;
var
I: Integer;
begin
I := Max(FFrameIndex, 0);
Result := (FItems.Count = 0) or
((TJvGIFFrame(FItems[I]).FBitmap = nil) and
((TJvGIFFrame(FItems[I]).FImage.FImageData = nil) or
(TJvGIFFrame(FItems[I]).FImage.FImageData.Size = 0)));
end;
function TJvGIFImage.GetPalette: HPALETTE;
begin
if FItems.Count > 0 then
Result := Bitmap.Palette
else
Result := 0;
end;
function TJvGIFImage.GetTransparent: Boolean;
var
I: Integer;
begin
if FTransparent then
for I := 0 to FItems.Count - 1 do
if Frames[I].TransparentColor <> clNone then
begin
Result := True;
Exit;
end;
Result := FTransparent;
end;
function TJvGIFImage.GetHeight: Integer;
begin
if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap.Height
else
Result := 0;
end;
function TJvGIFImage.GetWidth: Integer;
begin
if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap.Width
else
Result := 0;
end;
function TJvGIFImage.GetScreenWidth: Integer;
begin
if Empty then
Result := 0
else
Result := FScreenWidth;
end;
function TJvGIFImage.GetScreenHeight: Integer;
begin
if Empty then
Result := 0
else
Result := FScreenHeight;
end;
(*
procedure TJvGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
var
Bmp: TBitmap;
Stream: TMemoryStream;
Size: Longint;
Buffer: Pointer;
Data: THandle;
begin
{ !! check for gif clipboard Data, mime type image/gif }
Data := GetClipboardData(CF_JVGIF);
if Data <> 0 then
begin
Buffer := GlobalLock(Data);
try
Stream := TMemoryStream.Create;
try
Stream.Write(Buffer^, GlobalSize(Data));
Stream.Position := 0;
Stream.Read(Size, SizeOf(Size));
ReadStream(Size, Stream, False);
if Count > 0 then
begin
FFrameIndex := 0;
AData := GetClipboardData(CF_BITMAP);
if AData <> 0 then
begin
Frames[0].NewBitmap;
Frames[0].FBitmap.LoadFromClipboardFormat(CF_BITMAP, AData, APalette);
end;
end;
finally
Stream.Free;
end;
finally
GlobalUnlock(Data);
end;
end
else
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
Assign(Bmp);
finally
Bmp.Free;
end;
end;
end;
*)
procedure TJvGIFImage.LoadFromStream(Stream: TStream);
begin
ReadStream(Stream.Size - Stream.Position, Stream, True);
end;
procedure TJvGIFImage.LoadFromResourceName(Instance: THandle; const ResName: string);
var
Stream: TStream;
ResType: TResourceType;
begin
ResType := GetResourceType;
Stream := TResourceStream.Create(Instance, ResName, ResType);
try
ReadStream(Stream.Size - Stream.Position, Stream, True);
finally
Stream.Free;
end;
end;
procedure TJvGIFImage.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
ResType: TResourceType;
Stream: TStream;
begin
ResType := GetResourceType;
Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);
try
ReadStream(Stream.Size - Stream.Position, Stream, True);
finally
Stream.Free;
end;
end;
procedure TJvGIFImage.UpdateScreenSize;
var
I: Integer;
begin
FScreenWidth := 0;
FScreenHeight := 0;
for I := 0 to FItems.Count - 1 do
if Frames[I] <> nil then
begin
FScreenWidth := Max(FScreenWidth, Frames[I].Width +
Frames[I].FTopLeft.X);
FScreenHeight := Max(FScreenHeight, Frames[I].Height +
Frames[I].FTopLeft.Y);
end;
end;
function TJvGIFImage.AddFrame(Value: TGraphic): Integer;
begin
FFrameIndex := FItems.Add(TJvGIFFrame.Create(Self));
TJvGIFFrame(FItems[FFrameIndex]).Assign(Value);
if FVersion = gvUnknown then
FVersion := gv87a;
if FItems.Count > 1 then
FVersion := gv89a;
Result := FFrameIndex;
end;
procedure TJvGIFImage.DeleteFrame(Index: Integer);
begin
Frames[Index].Free;
FItems.Delete(Index);
UpdateScreenSize;
if FFrameIndex >= FItems.Count then
Dec(FFrameIndex);
Changed(Self);
end;
procedure TJvGIFImage.MoveFrame(CurIndex, NewIndex: Integer);
begin
FItems.Move(CurIndex, NewIndex);
FFrameIndex := NewIndex;
Changed(Self);
end;
procedure TJvGIFImage.NewImage;
begin
if FImage <> nil then
FImage.Release;
FImage := TGIFData.Create;
FImage.Reference;
if FItems = nil then
FItems := TList.Create;
ClearItems;
FCorrupted := False;
FFrameIndex := -1;
FBackgroundColor := clNone;
FRepeatCount := 1;
FLooping := False;
FVersion := gvUnknown;
end;
procedure TJvGIFImage.UniqueImage;
var
Temp: TGIFData;
begin
if FImage = nil then
NewImage
else
if FImage.RefCount > 1 then
begin
Temp := TGIFData.Create;
with Temp do
try
FComment.Assign(FImage.FComment);
FAspectRatio := FImage.FAspectRatio;
FBitsPerPixel := FImage.FBitsPerPixel;
FColorResBits := FImage.FColorResBits;
FColorMap := FImage.FColorMap;
except
Temp.Free;
raise;
end;
FImage.Release;
FImage := Temp;
FImage.Reference;
end;
end;
function TJvGIFImage.GetComment: TStrings;
begin
Result := FImage.FComment;
end;
procedure TJvGIFImage.SetComment(Value: TStrings);
begin
UniqueImage;
FImage.FComment.Assign(Value);
end;
procedure TJvGIFImage.DecodeAllFrames;
var
FrameNo, I: Integer;
begin
for FrameNo := 0 to FItems.Count - 1 do
try
TJvGIFFrame(FItems[FrameNo]).GetBitmap;
except
on EAbort do
begin { OnProgress can raise EAbort to cancel image load }
for I := FItems.Count - 1 downto FrameNo do
begin
TObject(FItems[I]).Free;
FItems.Delete(I);
end;
FCorrupted := True;
Break;
end;
else
raise;
end;
end;
procedure TJvGIFImage.EncodeFrames(ReverseDecode: Boolean);
var
FrameNo: Integer;
begin
for FrameNo := 0 to FItems.Count - 1 do
with TJvGIFFrame(FItems[FrameNo]) do
begin
if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then
begin
FImage.FImageData.Free;
FImage.FImageData := nil;
EncodeRasterData;
if ReverseDecode and (FBitmap.Palette = 0) then
begin
FBitmap.Free;
FBitmap := nil;
try
GetBitmap;
except
on EAbort do
; { OnProgress can raise EAbort to cancel encoding }
else
raise;
end;
end;
end;
UpdateExtensions;
end;
end;
procedure TJvGIFImage.EncodeAllFrames;
begin
EncodeFrames(True);
end;
procedure TJvGIFImage.ReadData(Stream: TStream);
var
Size: Longint = 0;
begin
Stream.Read(Size, SizeOf(Size));
ReadStream(Size, Stream, True);
end;
procedure TJvGIFImage.ReadSignature(Stream: TStream);
var
I: TGIFVersion;
S: TGifSignature;
begin
FVersion := gvUnknown;
S := Default(TGifSignature);
Stream.Read(S[0], 3);
if not CompareMem(@GIFSignature[0], @S[0], 3) then
GifError(RsEGIFVersion);
Stream.Read(S[0], 3);
for I := Low(TGIFVersion) to High(TGIFVersion) do
if CompareMem(@S[0], @GIFVersionStr[I][0], 3) then
begin
FVersion := I;
Break;
end;
if FVersion = gvUnknown then
GifError(RsEGIFVersion);
end;
procedure TJvGIFImage.ReadStream(Size: Longint; Stream: TStream;
ForceDecode: Boolean);
var
SeparatorChar: AnsiChar;
NewItem: TJvGIFFrame;
Extensions: TList;
ScreenDesc: TScreenDescriptor;
Data: TMemoryStream;
procedure ReadScreenDescriptor(Stream: TStream);
begin
Stream.Read(ScreenDesc, SizeOf(ScreenDesc));
FScreenWidth := ScreenDesc.ScreenWidth;
FScreenHeight := ScreenDesc.ScreenHeight;
with FImage do
begin
FAspectRatio := ScreenDesc.AspectRatio;
FBitsPerPixel := 1 + (ScreenDesc.PackedFields and
LSD_COLOR_TABLE_SIZE);
FColorResBits := 1 + (ScreenDesc.PackedFields and
LSD_COLOR_RESOLUTION) shr 4;
end;
end;
procedure ReadGlobalColorMap(Stream: TStream);
begin
if (ScreenDesc.PackedFields and LSD_GLOBAL_COLOR_TABLE) <> 0 then
with FImage.FColorMap do
begin
Count := 1 shl FImage.FBitsPerPixel;
Stream.Read(Colors[0], Count * SizeOf(TGIFColorItem));
if Count > ScreenDesc.BackgroundColorIndex then
FBackgroundColor := ItemToRGB(Colors[ScreenDesc.BackgroundColorIndex]);
end;
end;
function ReadDataBlock(Stream: TStream): TStringList;
var
BlockSize: Byte = 0;
S: AnsiString = '';
begin
Result := TStringList.Create;
try
repeat
Stream.Read(BlockSize, SizeOf(Byte));
if BlockSize <> 0 then
begin
SetLength(S, BlockSize);
Stream.Read(S[1], BlockSize);
Result.Add(string(S));
end;
until (BlockSize = 0) or (Stream.Position >= Stream.Size);
except
Result.Free;
raise;
end;
end;
function ReadExtension(Stream: TStream): TExtension;
var
ExtensionLabel: Byte = 0;
begin
Result := TExtension.Create;
try
Stream.Read(ExtensionLabel, SizeOf(Byte));
with Result do
begin
if ExtensionLabel = ExtLabels[etGraphic] then
begin
{ graphic control extension }
FExtType := etGraphic;
Stream.Read(FExtRec.GCE, SizeOf(TGraphicControlExtension));
end
else
if ExtensionLabel = ExtLabels[etComment] then
begin
{ comment extension }
FExtType := etComment;
FData := ReadDataBlock(Stream);
end
else
if ExtensionLabel = ExtLabels[etPlainText] then
begin
{ plain text extension }
FExtType := etPlainText;
Stream.Read(FExtRec.PTE, SizeOf(TPlainTextExtension));
FData := ReadDataBlock(Stream);
end
else
if ExtensionLabel = ExtLabels[etApplication] then
begin
{ application extension }
FExtType := etApplication;
Stream.Read(FExtRec.APPE, SizeOf(TAppExtension));
FData := ReadDataBlock(Stream);
end
else
GifError(Format(RsEUnrecognizedGIFExt, [ExtensionLabel]));
end;
except
Result.Free;
raise;
end;
end;
function ReadSeparator(Stream: TStream): AnsiChar;
begin
Result := #0;
while (Stream.Size > Stream.Position) and (Result = #0) do
Stream.Read(Result, SizeOf(Byte));
end;
function ReadExtensionBlock(Stream: TStream; var SeparatorChar: AnsiChar): TList;
var
NewExt: TExtension;
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(MakeWord(Byte(NewExt.FData[0][2]),
Byte(NewExt.FData[0][3])), MAX_LOOP_COUNT);
end;
{ not supported yet, must be ignored }
NewExt.Free;
end
else
begin
if Result = nil then
Result := TList.Create;
Result.Add(NewExt);
end;
if Stream.Size > Stream.Position then
SeparatorChar := ReadSeparator(Stream)
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;
var
I: Integer;
Ext: TExtension;
begin
NewImage;
with FImage do
begin
if Size > 0 then
begin
Data := TMemoryStream.Create;
try
TMemoryStream(Data).SetSize(Size);
Stream.ReadBuffer(Data.Memory^, Size);
Data.Position := 0;
ReadSignature(Data);
ReadScreenDescriptor(Data);
ReadGlobalColorMap(Data);
SeparatorChar := ReadSeparator(Data);
while not (SeparatorChar in [CHR_TRAILER, #0]) and not (Data.Position >= Data.Size) do
begin
Extensions := ReadExtensionBlock(Data, SeparatorChar);
if SeparatorChar = CHR_IMAGE_SEPARATOR then
try
NewItem := TJvGIFFrame.Create(Self);
try
if FImage.FColorMap.Count > 0 then
NewItem.FImage.FBitsPerPixel := ColorsToBits(FImage.FColorMap.Count);
NewItem.FExtensions := Extensions;
Extensions := nil;
NewItem.LoadFromStream(Data);
FItems.Add(NewItem);
except
NewItem.Free;
raise;
end;
if not (Data.Position >= Data.Size) then
SeparatorChar := ReadSeparator(Data)
else
SeparatorChar := CHR_TRAILER;
if not (SeparatorChar in [CHR_EXT_INTRODUCER, CHR_IMAGE_SEPARATOR, CHR_TRAILER]) then
begin
SeparatorChar := #0;
{GifError(RsEGIFDecodeError);}
end;
except
FreeExtensions(Extensions);
raise;
end
else
if (FComment.Count = 0) and (Extensions <> nil) then
begin
try
{ trailig extensions }
for I := 0 to Extensions.Count - 1 do
begin
Ext := TExtension(Extensions[I]);
if (Ext <> nil) and (Ext.FExtType = etComment) then
begin
if FComment.Count > 0 then
FComment.Add(CrLf + CrLf);
FComment.AddStrings(Ext.FData);
end;
end;
finally
FreeExtensions(Extensions);
end;
end
else
if not (SeparatorChar in [CHR_TRAILER, #0]) then
GifError(SReadError);
end;
finally
Data.Free;
end;
end;
end;
if Count > 0 then
begin
FFrameIndex := 0;
if ForceDecode then
try
GetBitmap; { force bitmap creation }
except
Frames[0].Free;
FItems.Delete(0);
raise;
end;
end;
PaletteModified := True;
Changed(Self);
end;
(*
procedure TJvGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
var
Stream: TMemoryStream;
Data: THandle;
Buffer: Pointer;
I: Integer;
begin
{ !! check for gif clipboard format, mime type image/gif }
if FItems.Count = 0 then
Exit;
Frames[0].Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
for I := 0 to FItems.Count - 1 do
with Frames[I] do
begin
if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then
Exit;
end;
Stream := TMemoryStream.Create;
try
WriteStream(Stream, True);
Stream.Position := 0;
Data := GlobalAlloc(GMEM_MOVEABLE, Stream.Size);
try
if Data <> 0 then
begin
Buffer := GlobalLock(Data);
try
Stream.Read(Buffer^, Stream.Size);
SetClipboardData(CF_JVGIF, Data);
finally
GlobalUnlock(Data);
end;
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
end; *)
procedure TJvGIFImage.WriteData(Stream: TStream);
begin
WriteStream(Stream, True);
end;
procedure TJvGIFImage.SetHeight(Value: Integer);
begin
GifError(RsEChangeGIFSize);
end;
procedure TJvGIFImage.SetTransparent(Value: Boolean);
begin
if FTransparent = Value then
exit;
FTransparent := Value;
Changed(nil);
end;
procedure TJvGIFImage.SetWidth(Value: Integer);
begin
GifError(RsEChangeGIFSize);
end;
procedure TJvGIFImage.WriteStream(Stream: TStream; WriteSize: Boolean);
var
Separator: Byte;
Temp: Byte;
FrameNo: Integer;
Frame: TJvGIFFrame;
Mem: TMemoryStream;
Size: Longint;
StrList: TStringList;
procedure WriteSignature(Stream: TStream);
var
Header: TGIFHeader;
begin
Header.Signature := GIFSignature;
Move(GIFVersionStr[FVersion][0], Header.Version[0], 3);
Stream.Write(Header, SizeOf(TGIFHeader));
end;
procedure WriteScreenDescriptor(Stream: TStream);
var
ColorResBits: Byte;
ScreenDesc: TScreenDescriptor;
I: Integer;
begin
UpdateScreenSize;
with ScreenDesc do
begin
ScreenWidth := Self.FScreenWidth;
ScreenHeight := Self.FScreenHeight;
AspectRatio := FImage.FAspectRatio;
PackedFields := 0;
BackgroundColorIndex := 0;
if FImage.FColorMap.Count > 0 then
begin
PackedFields := PackedFields or LSD_GLOBAL_COLOR_TABLE;
ColorResBits := ColorsToBits(FImage.FColorMap.Count);
if FBackgroundColor <> clNone then
for I := 0 to FImage.FColorMap.Count - 1 do
if ColorToRGB(FBackgroundColor) =
ItemToRGB(FImage.FColorMap.Colors[I]) then
begin
BackgroundColorIndex := I;
Break;
end;
PackedFields := PackedFields + ((ColorResBits - 1) shl 4) +
(FImage.FBitsPerPixel - 1);
end;
end;
Stream.Write(ScreenDesc, SizeOf(ScreenDesc));
end;
procedure WriteDataBlock(Stream: TStream; Data: TStrings);
var
I: Integer;
S: AnsiString;
BlockSize: Byte;
begin
for I := 0 to Data.Count - 1 do
begin
S := AnsiString(Data[I]);
BlockSize := Min(Length(S), 255);
if BlockSize > 0 then
begin
Stream.Write(BlockSize, SizeOf(Byte));
Stream.Write(S[1], BlockSize);
end;
end;
BlockSize := 0;
Stream.Write(BlockSize, SizeOf(Byte));
end;
procedure WriteExtensionBlock(Stream: TStream; Extensions: TList);
var
I: Integer;
Ext: TExtension;
ExtensionLabel: Byte;
SeparateChar: Byte;
begin
SeparateChar := Byte(CHR_EXT_INTRODUCER);
for I := 0 to Extensions.Count - 1 do
begin
Ext := TExtension(Extensions[I]);
if Ext <> nil then
begin
Stream.Write(SeparateChar, SizeOf(Byte));
ExtensionLabel := ExtLabels[Ext.FExtType];
Stream.Write(ExtensionLabel, SizeOf(Byte));
case Ext.FExtType of
etGraphic:
begin
Stream.Write(Ext.FExtRec.GCE, SizeOf(TGraphicControlExtension));
end;
etComment:
WriteDataBlock(Stream, Ext.FData);
etPlainText:
begin
Stream.Write(Ext.FExtRec.PTE, SizeOf(TPlainTextExtension));
WriteDataBlock(Stream, Ext.FData);
end;
etApplication:
begin
Stream.Write(Ext.FExtRec.APPE, SizeOf(TAppExtension));
WriteDataBlock(Stream, Ext.FData);
end;
end;
end;
end;
end;
begin
if FItems.Count = 0 then
GifError(RsENoGIFData);
EncodeFrames(False);
Mem := TMemoryStream.Create;
try
if FImage.FComment.Count > 0 then
FVersion := gv89a;
WriteSignature(Mem);
WriteScreenDescriptor(Mem);
if FImage.FColorMap.Count > 0 then
with FImage.FColorMap do
Mem.Write(Colors[0], Count * SizeOf(TGIFColorItem));
if FLooping and (FItems.Count > 1) then
begin
{ write looping extension }
Separator := Byte(CHR_EXT_INTRODUCER);
Mem.Write(Separator, SizeOf(Byte));
Temp := ExtLabels[etApplication];
Mem.Write(Temp, SizeOf(Byte));
Temp := SizeOf(TAppExtension) - SizeOf(Byte);
Mem.Write(Temp, SizeOf(Byte));
Mem.Write(LoopExtNS[1], Temp);
StrList := TStringList.Create;
try
StrList.Add(Char(AE_LOOPING) + Char(Low(FRepeatCount)) +
Char(High(FRepeatCount)));
WriteDataBlock(Mem, StrList);
finally
StrList.Free;
end;
end;
Separator := Byte(CHR_IMAGE_SEPARATOR);
for FrameNo := 0 to FItems.Count - 1 do
begin
Frame := TJvGIFFrame(FItems[FrameNo]);
if Frame.FExtensions <> nil then
WriteExtensionBlock(Mem, Frame.FExtensions);
Mem.Write(Separator, SizeOf(Byte));
Frame.WriteImageDescriptor(Mem);
Frame.WriteLocalColorMap(Mem);
Frame.WriteRasterData(Mem);
end;
if FImage.FComment.Count > 0 then
begin
Separator := Byte(CHR_EXT_INTRODUCER);
Mem.Write(Separator, SizeOf(Byte));
Temp := ExtLabels[etComment];
Mem.Write(Temp, SizeOf(Byte));
WriteDataBlock(Mem, FImage.FComment);
end;
Separator := Byte(CHR_TRAILER);
Mem.Write(Separator, SizeOf(Byte));
Size := Mem.Size;
if WriteSize then
Stream.Write(Size, SizeOf(Size));
Stream.Write(Mem.Memory^, Size);
finally
Mem.Free;
end;
end;
procedure TJvGIFImage.Grayscale(ForceEncoding: Boolean);
var
I: Integer;
begin
if FItems.Count = 0 then
GifError(RsENoGIFData);
for I := 0 to FItems.Count - 1 do
Frames[I].GrayscaleImage(ForceEncoding);
if FBackgroundColor <> clNone then
begin
if FImage.FColorMap.Count > 0 then
begin
I := FindColorIndex(FImage.FColorMap, FBackgroundColor);
GrayColorTable(FImage.FColorMap);
if I >= 0 then
FBackgroundColor := ItemToRGB(FImage.FColorMap.Colors[I])
else
FBackgroundColor := GrayColor(FBackgroundColor);
end
else
FBackgroundColor := GrayColor(FBackgroundColor);
end;
PaletteModified := True;
Changed(Self);
end;
procedure TJvGIFImage.SaveToStream(Stream: TStream);
begin
WriteStream(Stream, False);
end;
procedure TJvGIFImage.DoProgress(Stage: TProgressStage; PercentDone: Byte;
const Msg: string);
begin
Progress(Self, Stage, PercentDone, False, Rect(0, 0, 0, 0), Msg);
end;
procedure Init;
begin
CF_JVGIF := RegisterClipboardFormat('JvGIF Image');
{$IFDEF COMPILER7_UP}
GroupDescendentsWith(TJvGIFFrame, TControl);
GroupDescendentsWith(TJvGIFImage, TControl);
{$ENDIF COMPILER7_UP}
RegisterClasses([TJvGIFFrame, TJvGIFImage]);
{$IFDEF USE_JV_GIF}
TPicture.RegisterFileFormat('gif', RsGIFImage, TJvGIFImage);
{$ELSE}
TPicture.RegisterFileFormat('', '', TJvGIFImage); // register for loading but do not show in FileDialog
{$ENDIF USE_JV_GIF}
TPicture.RegisterClipboardFormat(CF_JVGIF, TJvGIFImage);
(********** NOT CONVERTED ***
RegisterGraphicSignature('GIF', 0, TJvGIFImage);
****************************)
end;
initialization
Init;
finalization
TPicture.UnRegisterGraphicClass(TJvGIFImage);
end.
Reference in New Issue View Git Blame Copy Permalink