Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/Source/frxGif1.pas

3018 lines
77 KiB
ObjectPascal
Raw Permalink Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{***************************************************************}
{* htmlgif1.pas *}
{* *}
{* Thanks to Ron Collins for the Gif code in this module. *}
{* His copyright notice is below. *}
{* *}
{* This is only a portion of his code modified slightly *}
{* in a few places to accomodate my own needs. Ron's *}
{* full package may be found at www.Torry.net/gif.htm. *}
{* The zip file is rctgif.zip. *}
{* *}
{***************************************************************}
{ ============================================================================
TGif.pas copyright (C) 2000 R. Collins
rlcollins@ksaits.com
LEGAL STUFF:
This software is provided "as-is". This software comes without warranty
or garantee, explicit or implied. Use this software at your own risk.
The author will not be liable for any damage to equipment, data, or information
that may result while using this software.
By using this software, you agree to the conditions stated above.
This software may be used freely, provided the author's name and copyright
statement remain a part of the source code.
NOTE: CompuServe, Inc. holds the patent to the compression algorithym
used in creating a GIF file. Before you save a GIF file (using LZW
compression) that may be distributed for profit, make sure you understand
the full implications and legal ramifications of using the LZW compression.
============================================================================ }
{$I frx.inc}
unit frxGif1;
interface
uses
{$IFDEF UseCLX}
SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,
QStdCtrls,
{$ELSE}
{$ifdef FPC}
LclIntf, LclType, IntfGraphics, //LMessages,
{$else}
Windows,
{$endif}
Messages, SysUtils, Classes, Graphics,
{$ENDIF}
Math;
type
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF not defined(DOTNET) and not defined(FPC)}
{$IF declared(INT_PTR)}
PtrInt = INT_PTR;
{$ELSE}
{$IFDEF WIN32}
PtrInt = LongInt;
{$ENDIF}
{$IFDEF WIN64}
PtrInt = Int64;
{$ENDIF}
{$IFEND}
{$IF declared(UINT_PTR)}
PtrUInt = UINT_PTR;
{$ELSE}
{$IFDEF WIN32}
PtrUInt = LongWord;
{$ENDIF}
{$IFDEF WIN64}
PtrUInt = Int64;
{$ENDIF}
{$IFEND}
{$IFEND}
{$ELSE}
PrtInt = LongInt;
PtrUInt = LongWord;
{$ENDIF}
// LZW encode table sizes
const
kGifCodeTableSize = 4096;
// the parts of a GIF file
// yes, yes, I know ... I don't have to put in "type"
// before each record definition. I just think it makes it
// easier to read, especially when the definitions may be broken
// across the printed page. if you don't like it, take them out.
type {LDB}
TRGBQUAD = packed record
rgbBlue: Byte;
rgbGreen: Byte;
rgbRed: Byte;
rgbReserved: Byte;
end;
type
PGifDataBlock = ^TGifDataBlock;
TGifDataBlock = record // generic data clump
rSize: integer; // NOTE: array starts at "1"
rData: packed array[1..255] of byte;
end;
type
PGifSignature = ^TgifSignature;
TGifSignature = record // GIF87A or GIF89A
rSignature: packed array[1..6] of Ansichar;
end;
type
PGifExtensionGraphic = ^TgifExtensionGraphic;
TGifExtensionGraphic = record // graphic control extension
rBlockSize: integer; // must always be 4
rDisposal: integer; // disposal method when drawing
rUserInputValid: boolean; // wait for user input?
rTransparentValid: boolean; // transparent color given?
rDelayTime: integer; // delay between display images
rTransparentIndex: integer; // into color table
end;
type
PGifExtensionComment = ^TgifExtensionComment;
TGifExtensionComment = record // comment extension
rDataBlockList: TList; // data blocks
end;
type
PGifExtensionText = ^TGifExtensionText;
TGifExtensionText = record // plain text extension
rBlockSize: integer; // must always be 12
rGridLeft: integer; // text grid position
rGridTop: integer;
rGridWidth: integer; // text grid size
rGridHeight: integer;
rCellWidth: integer; // size of a character cell
rCellHeight: integer;
rForegroundIndex: integer; // text foreground color
rBackgroundIndex: integer; // text background color
rDataBlockList: TList; // data blocks
end;
type
PGifExtensionApplication = ^TgifExtensionApplication;
TGifExtensionApplication = record // application extension
rBlockSize: integer; // must always be 11
rIdentifier: packed array[1..8] of Ansichar;
rAuthentication: packed array[1..3] of Ansichar;
rDataBlockList: TList; // data blocks
end;
type
PGifExtension = ^TGifExtension;
TGifExtension = record // for any extension type
case rLabel: byte of // cannot use CONST names
$F9: (rGraphic: TGifExtensionGraphic);
$FE: (rComment: TGifExtensionComment);
$01: (rText: TGifExtensionText);
$FF: (rApp: TGifExtensionApplication);
$00: (rDummy: longint);
end;
type
PGifScreenDescriptor = ^TGifScreenDescriptor;
TGifScreenDescriptor = record
rWidth: integer; // size of logical screen
rHeight: integer; // size of logical screen
rGlobalColorValid: boolean; // global color table found in file?
rColorResolution: integer; // bits per color
rSorted: boolean; // global colors are sorted?
rGlobalColorSize: integer; // size of global color table
rBackgroundIndex: integer; // background color index
rAspectRatio: integer; // pixel aspect ratio
rGlobalColorTable: integer; // default color table for all images
end;
type
PGifColorTable = ^TGifColorTable; // pointer to a color table
TGifColorTable = record
rSize: integer; // number of valid entries
rColors: array[0..255] of TColor; // the colors
end;
type
PGifImageDescriptor = ^TGifImageDescriptor;
TGifImageDescriptor = record
rIndex: integer; // which image is this?
rLeft: integer; // position of image
rTop: integer; // position of image
rWidth: integer; // size of image
rHeight: integer; // size of image
rLocalColorValid: boolean; // color table used?
rInterlaced: boolean; // interlaced lines?
rSorted: boolean; // color table sorted?
rLocalColorSize: integer; // number entries in local color table
rLocalColorTable: integer; // index into master list
rLZWSize: integer; // LZW minimum code size
rExtensionList: TList; // extensions read before this image
rPixelList: PByte; // decoded pixel indices
rPixelCount: longint; // number of pixels
rBitmap: TBitmap; // the actual image
end;
type
PGifZip = ^TGifZip;
TGifZip = record
rID: PGifImageDescriptor; // image parameters to decode
rCT: PGifColorTable; // color table for this image
rPrefix: array[0..kGifCodeTableSize - 1] of integer; // string prefixes
rSuffix: array[0..kGifCodeTableSize - 1] of integer; // string suffixes
rCodeStack: array[0..kGifCodeTableSize - 1] of byte; // decode/encoded pixels
rSP: integer; // pointer into CodeStack
rClearCode: integer; // reset decode params
rEndCode: integer; // last code in input stream
rHighCode: integer; // highest LZW code possible
rCurSize: integer; // current code size
rBitString: integer; // steady stream of bits to be decoded
rBits: integer; // number of valid bits in BitString
rCurSlot: integer; // next stack index to store a code
rTopSlot: integer; // highest slot used so far
rMaxVal: boolean; // max code value found?
rCurX: integer; // position of next pixel
rCurY: integer; // position of next pixel
rCurPass: integer; // pixel line pass 1..4
rFirstSlot: integer; // for encoding an image
rNextSlot: integer; // for encoding
rCount: integer; // number of bytes read/written
rLast: integer; // last byte read in
rUnget: boolean; // read a new byte, or use zLast?
end;
{ ---------------------------------------------------------------------------- }
{ ThtBitmap }
TfrxHtBitmap = class(TBitmap)
private
procedure SetMask(AValue: TBitmap);
function GetMask: TBitmap;
procedure SetTransparentMask(AValue: Boolean);
protected
FMask: TBitmap;
FTransparentMask: boolean;
property TransparentMask: Boolean read FTransparentMask write SetTransparentMask;
public
constructor Create(WithTransparentMask: Boolean = False); reintroduce; overload;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure StretchDraw(ACanvas: TCanvas; const DestRect, SrcRect: TRect);
property BitmapMask: TBitmap read GetMask write SetMask;
end;
// define a GIF
type
TGif = class(TObject)
private
fIOStream: TMemoryStream; // read or write the image
fDataStream: TMemoryStream; // temp storage for LZW
fExtension: TList; // latest extensions read/written
fSignature: PGifSignature; // version of GIF
fScreenDescriptor: PGifScreenDescriptor; // logical screen descriptor
fImageDescriptorList: TList; // list of all images
fColorTableList: TList; // list of all color tables
fPaletteList: TList; // list of palettes from color tables
fZipData: PGifZip; // for encode/decode image
FLoopCount: integer; // number of animated iterations
// functions that override TGraphic items
protected
function GetHeight: integer;
function GetWidth: integer;
function GetTransparent: boolean;
// procedures to read a bitmap
private
procedure ReadSignature;
procedure ReadScreenDescriptor;
procedure ReadColorTable(Size: integer; out Table: integer);
procedure ReadImageDescriptor;
procedure ReadDataBlockList(List: TList);
procedure ReadExtension(var Done: boolean);
procedure ReadSourceInteger(size: integer; out value: integer);
// write a GIF file
procedure WriteSignature;
procedure WriteScreenDescriptor;
procedure WriteColorTable(Table: integer);
procedure WriteExtension(eb: PGifExtension);
procedure WriteDataBlockList(List: TList);
procedure WriteImageDescriptor(id: PGifImageDescriptor);
procedure WriteSourceInteger(size: integer; var value: integer);
// LZW encode and decode
procedure LZWDecode(pID: PGifImageDescriptor);
procedure LZWEncode(pID: PGifImageDescriptor);
procedure LZWInit(pID: PGifImageDescriptor);
procedure LZWFinit;
procedure LZWReset;
function LZWGetCode: integer;
procedure LZWSaveCode(Code: integer);
procedure LZWDecodeCode(var Code: integer);
procedure LZWSaveSlot(Prefix, Suffix: integer);
procedure LZWIncrPosition;
procedure LZWCheckSlot;
procedure LZWWriteBitmap;
procedure LZWPutCode(code: integer);
procedure LZWPutClear;
function LZWReadBitmap: integer;
// procedures used to implement the PROPERTIES
function GetSignature: AnsiString;
function GetScreenDescriptor: PGifScreenDescriptor;
function GetImageCount: integer;
function GetImageDescriptor(image: integer): PGifImageDescriptor;
function GetBitmap(image: integer): TBitmap;
function GetColorTableCount: integer;
function GetColorTable(table: integer): PGifColorTable;
function GetImageDelay(Image: integer): integer; {LDB}
function GetImageDisposal(Image: integer): integer; {LDB}
function GetColorIndex(image, x, y: integer): integer;
function GetTransparentIndex(image: integer): integer;
function GetTransparentColor: TColor;
function GetImageLeft(image: integer): integer;
function GetImageTop(image: integer): integer;
function GetImageWidth(image: integer): integer;
function GetImageHeight(image: integer): integer;
function GetImageDepth(image: integer): integer;
// generally usefull routines
procedure FreeDataBlockList(var list: TList);
procedure FreeExtensionList(var list: TList);
procedure MakeBitmaps;
function FindGraphicExtension(image: integer): PGifExtensionGraphic;
function FindColorIndex(c: TColor; ct: PGifColorTable): integer;
procedure ExtractLoopCount(List: TList);
public
constructor Create;
constructor CreateCopy(AGif: TGif);
destructor Destroy; override;
procedure FreeImage;
procedure SaveToStream(Destination: TStream);
procedure LoadFromStream(Source: TStream);
function GetStripBitmap(): TfrxHtBitmap; {LDB}
property Signature: AnsiString read GetSignature;
property ScreenDescriptor: PGifScreenDescriptor read GetScreenDescriptor;
property ImageCount: integer read GetImageCount;
property ImageDescriptor[Image: integer]: PGifImageDescriptor read GetImageDescriptor;
property Bitmap[Image: integer]: TBitmap read GetBitmap;
property ColorTableCount: integer read GetColorTableCount;
property ColorTable[Table: integer]: PGifColorTable read GetColorTable;
property Height: integer read GetHeight;
property Width: integer read GetWidth;
property ImageDelay[Image: integer]: integer read GetImageDelay;
property ImageDisposal[Image: integer]: integer read GetImageDisposal;
property Transparent: boolean read GetTransparent;
property TransparentIndex[Image: integer]: integer read GetTransparentIndex;
property TransparentColor: TColor read GetTransparentColor;
property ImageLeft[Image: integer]: integer read GetImageLeft;
property ImageTop[Image: integer]: integer read GetImageTop;
property ImageWidth[Image: integer]: integer read GetImageWidth;
property ImageHeight[Image: integer]: integer read GetImageHeight;
property ImageDepth[Image: integer]: integer read GetImageDepth;
property LoopCount: integer read FLoopCount;
end;
implementation
{$IFDEF UNICODE}
uses
AnsiStrings;
{$ENDIF}
const
TransColor = $170725;
// GIF record separators
const
kGifImageSeparator: byte = $2C;
kGifExtensionSeparator: byte = $21;
kGifTerminator: byte = $3B;
kGifLabelGraphic: byte = $F9;
kGifLabelComment: byte = $FE;
kGifLabelText: byte = $01;
kGifLabelApplication: byte = $FF;
// define a set of error messages
const
kGifErrorMessages: array[0..27] of string = (
'no error', // 0
'Invalid GIF Signature Code', // 1
'No Local or Global Color Table for Image', // 2
'Unknown Graphics Extension Type', // 3
'Unknown Graphics Operation Code', // 4
'Invalid Extension Block Size', // 5
'[special message]', // 6
'Invalid Extension Block Terminator', // 7
'Invalid Integer Size', // 8
'No GIF Terminator Found', // 9
'Extension Block Out-Of-Order With Image Data', // 10
'Invalid Image Descriptor Index', // 11
'Invalid LZW Code Size', // 12
'Invalid LZW Data Format', // 13
'LZW Code Overflow', // 14
'Value Out Of Range', // 15
'NIL Pointer assigned', // 16
'Invalid Color Table Size', // 17
'No Image Description', // 18
'Invalid Bitmap Image', // 19
'Invalid Color Table Index', // 20
'Invalid Interlace Pass', // 21
'Invalid Bitmap', // 22
'Too Many Colors In Bitmap', // 23
'Unexpected end of file', // 24 {LDB}
'Animated GIF too large', // 25 {LDB}
'Zero width or height', // 26 {LDB}
'next message' //
);
var
GIF_ErrorCode: integer; // last error
GIF_ErrorString: string; // last error
procedure GIF_Error(n: integer); forward;
procedure GIF_ErrorMessage(m: string); forward;
constructor TGif.Create;
begin
inherited Create;
// nothing defined yet
fIOStream := nil;
fDataStream := nil;
fExtension := nil;
fSignature := nil;
fScreenDescriptor := nil;
fImageDescriptorList := nil;
fColorTableList := nil;
fPaletteList := nil;
fZipData := nil;
FLoopCount := -1; // -1 is no loop count entered
// some things, though, will always be needed
new(fSignature);
if (fSignature = nil) then
OutOfMemoryError;
fSignature^.rSignature := AnsiString('------');
new(fScreenDescriptor);
if (fScreenDescriptor = nil) then
OutOfMemoryError;
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);
fImageDescriptorList := TList.Create;
fColorTableList := TList.Create;
fPaletteList := TList.Create;
end;
constructor TGif.CreateCopy(AGif: TGif);
var
Stream: TStream;
begin
Create;
Stream := TMemoryStream.Create;
try
AGif.SaveToStream(Stream);
Stream.Position := 0;
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
destructor TGif.Destroy;
begin
// clean up most of the data
FreeImage;
// and then the left-overs
dispose(fSignature);
dispose(fScreenDescriptor);
fImageDescriptorList.Free;
fColorTableList.Free;
fPaletteList.Free;
// and the ancestor
inherited;
end;
{ ---------------------------------------------------------------------------- }
{ release all memory used to store image data }
procedure TGif.FreeImage;
var
i: integer;
id: PGifImageDescriptor;
ct: PGifColorTable;
begin
// temp input/output stream
if (fIOStream <> nil) then
fIOStream.Free;
fIOStream := nil;
// temp encoded data
if (fDataStream <> nil) then
fDataStream.Free;
fDataStream := nil;
// temp list of image extensions
if (fExtension <> nil) then
FreeExtensionList(fExtension);
fExtension := nil;
// signature record stays, but is cleared
if (fSignature = nil) then
new(fSignature);
fSignature^.rSignature := AnsiString('------');
// ditto the screen descriptor
if (fScreenDescriptor = nil) then
new(fScreenDescriptor);
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);
// delete all items from image list, but leave the list
if (fImageDescriptorList = nil) then
fImageDescriptorList := TList.Create;
for i := 0 to (fImageDescriptorList.Count - 1) do
begin
id := fImageDescriptorList.Items[i];
if (id <> nil) then
begin
if (id^.rExtensionList <> nil) then
FreeExtensionList(id^.rExtensionList);
if (id^.rPixelList <> nil) then
freemem(id^.rPixelList);
if (id^.rBitmap <> nil) then
id^.rBitmap.Free;
dispose(id);
end;
end;
fImageDescriptorList.Clear;
// release color tables, but keep the list
if (fColorTableList = nil) then
fColorTableList := TList.Create;
for i := 0 to (fColorTableList.Count - 1) do
begin
ct := fColorTableList.Items[i];
if (ct <> nil) then
dispose(ct);
end;
fColorTableList.Clear;
// once again, keep the palette list object, but not the data
if (fPaletteList = nil) then
fPaletteList := TList.Create;
fPaletteList.Clear;
// don't need the zip/unzip data block
if (fZipData <> nil) then
dispose(fZipData);
fZipData := nil;
end;
{ ---------------------------------------------------------------------------- }
{ READ and WRITE A GIF ------------------------------------------------------- }
{ ---------------------------------------------------------------------------- }
{ read a GIF definition from a stream }
procedure TGif.LoadFromStream(Source: TStream);
var
done: boolean;
b: byte;
SourcePosition: Int64;
begin
// release old image that may be here ...
FreeImage;
// no error yet
GIF_ErrorCode := 0;
GIF_ErrorString := '';
// make a local copy of the source data
// memory streams are faster and easier to manipulate than file streams
fIOStream := TMemoryStream.Create;
SourcePosition := Source.Position;
fIOStream.LoadFromStream(Source);
fIOStream.Position := SourcePosition;
// local temp vars
fDataStream := TMemoryStream.Create; // data to be un-zipped
fExtension := nil; // extensions to an image
// read the signature GIF87A or GIF89A
ReadSignature;
// read the logical screen descriptor
ReadScreenDescriptor;
// read extensions and image data until end of file
done := false;
while (not done) do
try {LDB}
if (fIOStream.Position >= fIOStream.Size) then
//GIF_Error(9); {LDB}
b := 0 {LDB}
else
fIOStream.Read(b, 1); {LDB} // image separator
if (b = 0) then // just skip this?
begin
b := 0;
Done := True; {LDB}
end
else if (b = kGifTerminator) then // got it all
begin
done := true;
end
else if (b = kGifImageSeparator) then // next bitmap
begin
ReadImageDescriptor;
end
else if (b = kGifExtensionSeparator) then // special operations
begin
ReadExtension(Done);
end
else // unknown
begin
GIF_Error(4);
end;
except {LDB}
if GetImageCount > 0 then
Done := True {use what images we have}
else
raise;
end;
// must have an image -- must be commented out for the FR
// if (fImageDescriptorList.Count = 0) then
// GIF_Error(18);
// no longer need the source data in memory
fIOStream.Free;
fDataStream.Free;
FreeExtensionList(fExtension);
fIOStream := nil;
fDataStream := nil;
fExtension := nil;
end;
function TGif.GetHeight: integer;
begin
GetHeight := fScreenDescriptor^.rHeight;
end;
function TGif.GetWidth: integer;
begin
GetWidth := fScreenDescriptor^.rWidth;
end;
{ ---------------------------------------------------------------------------- }
{ TRANSPARENT is assument to be the same for all images; i.e., if the first }
{ image is transparent, they they are all transparent }
{ if SetTransparent(TRUE) then set default color index for transparent color }
{ this can be changed with TransparentColor after this call }
{LDB changed so that if any images are transparent, Transparent returns True}
function TGif.GetTransparent: boolean;
var
b: boolean;
gx: PGifExtensionGraphic;
i: integer;
begin
b := false;
for I := 0 to (fImageDescriptorList.Count - 1) do
begin
gx := FindGraphicExtension(I);
if (gx <> nil) then
b := gx^.rTransparentValid or b;
end;
GetTransparent := b;
end;
{ ---------------------------------------------------------------------------- }
{ PROCEDURES TO READ A GIF FILE ---------------------------------------------- }
{ ---------------------------------------------------------------------------- }
{ read the GIF signature from the source stream }
{ this assumes the memory stream position is correct }
{ the signature is always 6 bytes, and must be either GIF87A or GIF89A }
procedure TGif.ReadSignature;
var
s: AnsiString;
begin
with fSignature^ do
begin
fIOStream.Read(rSignature, 6);
s := rSignature;
s := AnsiUpperCase(s);
if ((s <> 'GIF87A') and (s <> 'GIF89A')) then
GIF_Error(1);
end;
end;
{ ---------------------------------------------------------------------------- }
{ read the GIF logical screen descriptor from the source stream }
{ this assumes the memory stream position is correct }
{ this always follows the GIF signature }
procedure TGif.ReadScreenDescriptor;
var
i, n: integer;
begin
with fScreenDescriptor^ do
begin
ReadSourceInteger(2, rWidth); // logical screen width
ReadSourceInteger(2, rHeight); // logical screen height
ReadSourceInteger(1, n); // packed bit fields
rGlobalColorValid := ((n and $80) <> 0);
rColorResolution := ((n shr 4) and $07) + 1;
rSorted := ((n and $08) <> 0);
i := (n and $07);
if (i = 0) then
rGlobalColorSize := 2
else if (i = 1) then
rGlobalColorSize := 4
else if (i = 2) then
rGlobalColorSize := 8
else if (i = 3) then
rGlobalColorSize := 16
else if (i = 4) then
rGlobalColorSize := 32
else if (i = 5) then
rGlobalColorSize := 64
else if (i = 6) then
rGlobalColorSize := 128
else if (i = 7) then
rGlobalColorSize := 256
else
rGlobalColorSize := 256;
ReadSourceInteger(1, rBackgroundIndex); // background color
ReadSourceInteger(1, rAspectRatio); // pixel aspect ratio
// read the global color table from the source stream
// this assumes the memory stream position is correct
// the global color table is only valid if a flag is set in the logical
// screen descriptor. if the flag is set, the global color table will
// immediately follow the logical screen descriptor
rGlobalColorTable := -1;
if (rGlobalColorValid) then // a global color table?
ReadColorTable(rGlobalColorSize, rGlobalColorTable)
end;
end;
{ ---------------------------------------------------------------------------- }
{ read in any type of color table }
{ number of RGB entries is given by SIZE, and save the index into the }
{ master color table list in TABLE }
{ if SIZE is <= 0, then there is no table, and the TABLE becomes -1 }
procedure TGif.ReadColorTable(Size: integer; out Table: integer);
var
i, n: integer;
r, g, b: byte;
ct: PGifColorTable;
begin
Table := -1; // assume no table
if (Size > 0) then // OK, a table does exist
begin
new(ct); // make a anew color table
if (ct = nil) then
OutOfMemoryError;
n := fColorTableList.Add(ct); // save it in master list
Table := n; // save index for a valid table
ct^.rSize := Size;
for i := 0 to (ct^.rSize - 1) do // read a triplet for each TColor
begin
fIOStream.Read(r, 1); // red
fIOStream.Read(g, 1); // green
fIOStream.Read(b, 1); // blue
ct^.rColors[i] := r or (g shl 8) or (b shl 16);
end;
// make sure we store palette handle in same index slot as the color table
while (fPaletteList.Count < fColorTableList.Count) do
fPaletteList.Add(nil);
fPaletteList.Items[Table] := nil;
end;
end;
{ ---------------------------------------------------------------------------- }
{ read the next image descriptor }
{ the source stream position should be immediately following the }
{ special code image separator }
{ note: this routine only reads in the raw data; the LZW de-compression }
{ occurs later, after all the data has been read }
{ this probably makes for a bigger data chunk, but it doesn't much effect }
{ the speed, and it is certainly a more modular approach and is much easier }
{ to understand the mechanics later }
procedure TGif.ReadImageDescriptor;
var
i, n: integer;
ix: integer;
id: PGifImageDescriptor;
db: TGifDataBlock;
begin
// make a new image desctiptor record and add this record to main list
new(id);
if (id = nil) then
OutOfMemoryError;
if (fImageDescriptorList = nil) then
fImageDescriptorList := TList.Create;
ix := fImageDescriptorList.Add(id);
id^.rIndex := ix;
// initialize data
fillchar(id^, sizeof(TGifImageDescriptor), 0);
// init the sotrage for compressed data
fDataStream.Clear;
// if extensions were read in earlier, save that list
// for this image descriptor
// if no extensions were read in, then we don't need this list at all
if (fExtension <> nil) then
begin
id^.rExtensionList := fExtension;
fExtension := nil;
end;
// shortcut to the record fields
with id^ do
begin
// read the basic descriptor record
ReadSourceInteger(2, rLeft); // left position
ReadSourceInteger(2, rTop); // top position
ReadSourceInteger(2, rWidth); // size of image
ReadSourceInteger(2, rHeight); // size of image
if rHeight > Height then {LDB make sure bad values don't overflow elsewhere}
rHeight := Height;
ReadSourceInteger(1, n); // packed bit field
rLocalColorValid := ((n and $80) <> 0);
rInterlaced := ((n and $40) <> 0);
rSorted := ((n and $20) <> 0);
i := (n and $07);
if (i = 0) then
rLocalColorSize := 2
else if (i = 1) then
rLocalColorSize := 4
else if (i = 2) then
rLocalColorSize := 8
else if (i = 3) then
rLocalColorSize := 16
else if (i = 4) then
rLocalColorSize := 32
else if (i = 5) then
rLocalColorSize := 64
else if (i = 6) then
rLocalColorSize := 128
else if (i = 7) then
rLocalColorSize := 256
else
rLocalColorSize := 256;
// if a local color table is defined, read it
// otherwise, use the global color table
if (rLocalColorValid) then
ReadColorTable(rLocalColorSize, rLocalColorTable)
else
rLocalColorTable := fScreenDescriptor^.rGlobalColorTable;
// _something_ must have defined by now ...
if (rLocalColorTable < 0) then
GIF_Error(2);
// the LZW minimum code size
ReadSourceInteger(1, rLZWSize);
// read data blocks until the end of the list
ReadSourceInteger(1, db.rSize);
while (db.rSize > 0) do
begin
if fIOStream.Read(db.rData, db.rSize) < db.rSize then
Gif_Error(24); {LDB}
fDataStream.Write(db.rData, db.rSize);
ReadSourceInteger(1, db.rSize);
end;
// save the pixel list
rPixelCount := rWidth * rHeight;
if rPixelCount = 0 then {LDB}
Gif_Error(26);
rPixelList := allocmem(rPixelCount);
if (rPixelList = nil) then
OutOfMemoryError;
// uncompress the data and write the bitmap
LZWDecode(id);
end; // with id^
end;
{ ---------------------------------------------------------------------------- }
{ read in a group of data blocks until a zero-length block is found }
{ store the data on the give TList }
procedure TGif.ReadDataBlockList(List: TList);
var
b: byte;
db: PGifDataBlock;
BytesRead: integer;
begin
// read data blocks until the end of the list
fIOStream.Read(b, 1); // size of next block
while (b > 0) do // more blocks to get?
begin
new(db); // new data block record
db^.rSize := b;
BytesRead := fIOStream.Read(db^.rData, db^.rSize); // read the data
List.Add(db); // save in given list
if BytesRead < db^.rSize then
Gif_Error(24); {LDB}
fIOStream.Read(b, 1); // size of next block
end;
end;
{ ---------------------------------------------------------------------------- }
{ read in any type of extension record }
{ assume that the source position is AFTER the extension separator, }
{ but BEFORE the specific extension label }
{ the extension record we read in is stored in the master extension }
{ list; however, the indexes for these exrtensions is stored in a }
{ temporary list which will be assigned to the next image descriptor }
{ record read in. this is because all extension blocks preceed the }
{ image descriptor to which they belong }
procedure TGif.ReadExtension(var Done: boolean);
var
n: integer;
b: byte;
eb: PGifExtension;
begin
// make a list exists
if (fExtension = nil) then
fExtension := TList.Create;
// make a new extension record and add it to temp holding list
new(eb);
if (eb = nil) then
OutOfMemoryError;
fillchar(eb^, sizeof(TGifExtension), 0);
fExtension.Add(eb);
// get the type of extension
fIOStream.Read(b, 1);
eb^.rLabel := b;
// "with eb^" gives us access to rGraphic, rText, rComment, and rApp
with eb^ do
begin
// a graphic extension
if (rLabel = kGifLabelGraphic) then
begin
ReadSourceInteger(1, rGraphic.rBlockSize); // block size
if (rGraphic.rBlockSize <> 4) then
GIF_Error(5);
ReadSourceInteger(1, n); // packed bit field
rGraphic.rDisposal := ((n shr 2) and $07);
rGraphic.rUserInputValid := ((n and $02) <> 0);
rGraphic.rTransparentValid := ((n and $01) <> 0);
ReadSourceInteger(2, rGraphic.rDelayTime); // delay time
ReadSourceInteger(1, rGraphic.rTransparentIndex); // transparent color
ReadSourceInteger(1, n); // block terminator
if (n <> 0) then
GIF_Error(7);
end
// a comment extension
else if (rLabel = kGifLabelComment) then
begin
rComment.rDataBlockList := TList.Create;
ReadDataBlockList(rComment.rDataBlockList);
end
// a plain text extension
else if (rLabel = kGifLabelText) then
begin
ReadSourceInteger(1, rText.rBlockSize); // block size
if (rText.rBlockSize <> 12) then
GIF_Error(5);
ReadSourceInteger(2, rText.rGridLeft); // grid position
ReadSourceInteger(2, rText.rGridTop); // grid position
ReadSourceInteger(2, rText.rGridWidth); // grid size
ReadSourceInteger(2, rText.rGridHeight); // grid size
ReadSourceInteger(1, rText.rCellWidth); // character cell size {LDB}{was 2 bytes}
ReadSourceInteger(1, rText.rCellHeight); // character cell size
ReadSourceInteger(1, rText.rForegroundIndex); // foreground color
ReadSourceInteger(1, rText.rBackgroundIndex); // background color
rText.rDataBlockList := TList.Create; // list of text data blocks
ReadDataBlockList(rText.rDataBlockList);
end
// an application extension
else if (rLabel = kGifLabelApplication) then
begin
ReadSourceInteger(1, rApp.rBlockSize); // block size
if (rApp.rBlockSize <> 11) then //GIF_Error(5); {LDB} allow other blocksizes
begin
fIOStream.Position := fIOStream.Position + rApp.rBlockSize;
rApp.rDataBlockList := TList.Create;
ReadDataBlockList(rApp.rDataBlockList);
end
else
begin
fIOStream.Read(rApp.rIdentifier, 8); // application identifier
fIOStream.Read(rApp.rAuthentication, 3); // authentication code
rApp.rDataBlockList := TList.Create;
ReadDataBlockList(rApp.rDataBlockList);
if rApp.rIdentifier = 'NETSCAPE' then
ExtractLoopCount(rApp.rDataBlockList);
end;
end
// unknown type
else
begin
GIF_ErrorMessage('unknown extension: ' + IntToHex(rLabel, 4));
end;
end; // with eb^
end;
{ ---------------------------------------------------------------------------- }
{ read a 1 or 2-byte integer from the source stream }
procedure TGif.ReadSourceInteger(size: integer; out value: integer);
var
b: byte;
w: word;
begin
if (size = 1) then
begin
fIOStream.Read(b, 1);
value := b;
end
else if (size = 2) then
begin
fIOStream.Read(w, 2);
value := w;
end
else
begin
GIF_Error(8);
end;
end;
procedure TGif.SaveToStream(Destination: TStream);
var
i, n: integer;
j: integer;
id: PGifImageDescriptor;
eb: PGifExtension;
begin
// no error yet
GIF_ErrorCode := 0;
GIF_ErrorString := '';
// init temp vars
fIOStream := TMemoryStream.Create;
fDataStream.Free;
fDataStream := TMemoryStream.Create;
fExtension := nil;
// write the GIF signature
WriteSignature;
// overall screen description
WriteScreenDescriptor;
// write data for each screen descriptor
for i := 0 to (fImageDescriptorList.Count - 1) do
begin
id := fImageDescriptorList.Items[i];
// write out extensions for this image
n := 0;
if (id^.rExtensionList <> nil) then
n := id^.rExtensionList.Count;
for j := 0 to (n - 1) do
begin
eb := id^.rExtensionList.Items[j];
fIOStream.Write(kGifExtensionSeparator, 1);
WriteExtension(eb);
end;
// write actual image data
fIOStream.Write(kGifImageSeparator, 1);
WriteImageDescriptor(id);
end; // write images
// done with writing
fIOStream.Write(kGifTerminator, 1);
// write to destination stream
Destination.CopyFrom(fIOStream, 0);
// done with temp data
fIOStream.Free;
fIOStream := nil;
end;
procedure TGif.WriteColorTable(Table: integer);
var
i, n: integer;
r, g, b: Byte;
c: TColor;
ct: PGifColorTable;
begin
if ((Table < 0) or (Table >= fColorTableList.Count)) then
GIF_Error(15);
ct := fColorTableList.Items[Table];
// for strange-sized tables, go to the next power of 2
n := ct^.rSize;
if (n <= 2) then
n := 2
else if (n <= 4) then
n := 4
else if (n <= 8) then
n := 8
else if (n <= 16) then
n := 16
else if (n <= 32) then
n := 32
else if (n <= 64) then
n := 64
else if (n <= 128) then
n := 128
else if (n <= 256) then
n := 256
else
n := 256;
// write the size
// WriteSourceInteger(1, n);
// write RGB values
for i := 0 to (n - 1) do
begin
c := ct^.rColors[i];
r := (c and $FF);
g := ((c shr 8) and $FF);
b := ((c shr 16) and $FF);
fIOStream.Write(r, 1);
fIOStream.Write(g, 1);
fIOStream.Write(b, 1);
end;
end;
procedure TGif.WriteDataBlockList(List: TList);
var
i: integer;
b: Byte;
db: PGifDataBlock;
begin
// write out the blocks that actually contain some data
for i := 0 to (List.Count - 1) do
begin
db := List.Items[i];
b := db^.rSize;
if (b > 0) then
begin
fIOStream.Write(b, 1);
fIOStream.Write(db^.rData, b);
end;
end;
// then write an end-of-block
b := 0;
fIOStream.Write(b, 1);
end;
procedure TGif.WriteExtension(eb: PGifExtension);
var
n: integer;
b: Byte;
begin
// write the extension label
b := eb^.rLabel;
fIOStream.Write(b, 1);
// "with eb^" gives us access to rGraphic, rText, rComment, and rApp
with eb^ do
begin
// a graphic extension
if (rLabel = kGifLabelGraphic) then
begin
WriteSourceInteger(1, rGraphic.rBlockSize); // block size (always 4)
n := 0; // packed bit field
n := (n or ((rGraphic.rDisposal and $07) shl 2));
if (rGraphic.rUserInputValid) then
n := (n or $02);
if (rGraphic.rTransparentValid) then
n := (n or $01);
WriteSourceInteger(1, n);
WriteSourceInteger(2, rGraphic.rDelayTime); // delay time
WriteSourceInteger(1, rGraphic.rTransparentIndex); // transparent color
n := 0;
WriteSourceInteger(1, n); // block terminator
end
// a comment extension
else if (rLabel = kGifLabelComment) then
begin
WriteDataBlockList(rComment.rDataBlockList);
end
// a plain text extension
else if (rLabel = kGifLabelText) then
begin
WriteSourceInteger(1, rText.rBlockSize); // block size (always 12)
WriteSourceInteger(2, rText.rGridLeft); // grid position
WriteSourceInteger(2, rText.rGridTop); // grid position
WriteSourceInteger(2, rText.rGridWidth); // grid size
WriteSourceInteger(2, rText.rGridHeight); // grid size
WriteSourceInteger(1, rText.rCellWidth); // character cell size {LDB}{was 2 bytes}
WriteSourceInteger(1, rText.rCellHeight); // character cell size
WriteSourceInteger(1, rText.rForegroundIndex); // foreground color
WriteSourceInteger(1, rText.rBackgroundIndex); // background color
WriteDataBlockList(rText.rDataBlockList); // the text data
end
// an application extension
else if (rLabel = kGifLabelApplication) then
begin
WriteSourceInteger(1, rApp.rBlockSize); // block size (always 11)
fIOStream.Write(rApp.rIdentifier, 8); // application identifier
fIOStream.Write(rApp.rAuthentication, 3); // authentication code
WriteDataBlockList(rApp.rDataBlockList); // misc data
end
// unknown type
else
begin
GIF_ErrorMessage('unknown extension: ' + IntToHex(rLabel, 4));
end;
end; // with eb^
end;
procedure TGif.WriteImageDescriptor(id: PGifImageDescriptor);
var
i, n: integer;
db: TGifDataBlock;
begin
// init the sotrage for compressed data
fDataStream.Clear;
// shortcut to the record fields
with id^ do
begin
// write the basic descriptor record
WriteSourceInteger(2, rLeft); // left position
WriteSourceInteger(2, rTop); // top position
WriteSourceInteger(2, rWidth); // size of image
WriteSourceInteger(2, rHeight); // size of image
n := 0; // packed bit field
if (rLocalColorSize <= 2) then
i := 0
else if (rLocalColorSize <= 4) then
i := 1
else if (rLocalColorSize <= 8) then
i := 2
else if (rLocalColorSize <= 16) then
i := 3
else if (rLocalColorSize <= 32) then
i := 4
else if (rLocalColorSize <= 64) then
i := 5
else if (rLocalColorSize <= 128) then
i := 6
else if (rLocalColorSize <= 256) then
i := 7
else
i := 7;
n := (n or i);
if (rLocalColorValid) then
n := (n or $80);
if (rInterlaced) then
n := (n or $40);
if (rSorted) then
n := (n or $20);
WriteSourceInteger(1, n);
// if a local color table is defined, write it
if (rLocalColorValid) then
WriteColorTable(rLocalColorTable);
// the LZW minimum code size
WriteSourceInteger(1, rLZWSize);
// encode the image and save it in DATASTREAM
LZWEncode(id);
// write out the data stream as a series of data blocks
fDataStream.Position := 0;
while (fDataStream.Position < fDataStream.Size) do
begin
n := fDataStream.Size - fDataStream.Position;
if (n > 255) then
n := 255;
db.rSize := n;
fDataStream.Read(db.rData, n);
fIOStream.Write(db.rSize, 1);
fIOStream.Write(db.rData, n);
end;
// block terminator
n := 0;
WriteSourceInteger(1, n);
end; // with id^
end;
procedure TGif.WriteScreenDescriptor;
var
i, n: integer;
begin
with fScreenDescriptor^ do
begin
WriteSourceInteger(2, rWidth); // logical screen width
WriteSourceInteger(2, rHeight); // logical screen height
n := 0; // packed bit fields
if (rGlobalColorValid) then
n := (n or $80);
n := (n or (((rColorResolution - 1) and $07) shl 4));
if (rSorted) then
n := (n or $08);
if (rGlobalColorSize <= 2) then
i := 0
else if (rGlobalColorSize <= 4) then
i := 1
else if (rGlobalColorSize <= 8) then
i := 2
else if (rGlobalColorSize <= 16) then
i := 3
else if (rGlobalColorSize <= 32) then
i := 4
else if (rGlobalColorSize <= 64) then
i := 5
else if (rGlobalColorSize <= 128) then
i := 6
else if (rGlobalColorSize <= 256) then
i := 7
else
i := 7;
n := (n or i);
WriteSourceInteger(1, n);
WriteSourceInteger(1, rBackgroundIndex); // background color
WriteSourceInteger(1, rAspectRatio); // pixel aspect ratio
// write the global color table to the source stream
if (rGlobalColorValid) then
WriteColorTable(rGlobalColorTable);
end;
end;
procedure TGif.WriteSignature;
var
id: PGifImageDescriptor;
begin
fSignature^.rSignature := 'GIF89a';
if (fImageDescriptorList.Count = 1) then
begin
id := fImageDescriptorList.Items[0];
if (id^.rExtensionList = nil) then
fSignature^.rSignature := 'GIF87a';
end;
fIOStream.Write(fSignature^.rSignature, 6);
end;
procedure TGif.WriteSourceInteger(size: integer; var value: integer);
var
b: Byte;
w: word;
begin
if (Size = 1) then
begin
b := value;
fIOStream.Write(b, 1);
end
else if (Size = 2) then
begin
w := value;
fIOStream.Write(w, 2);
end
else
begin
GIF_Error(8);
end;
end;
{ ---------------------------------------------------------------------------- }
{ decode the compressed data blocks into a bitmap }
procedure TGif.LZWDecode(pID: PGifImageDescriptor);
var
pc: integer; // next compressed code parsed from input
cc: integer; // current code to translate
oc: integer; // old code translated
tt: integer; // temp storage for OldCode
Done: boolean;
begin
// init local data
LZWInit(pID);
LZWReset;
// do everything within the ZIP record
with fZipData^ do
begin
// parse next code from BitString
pc := LZWGetCode;
oc := pc;
Done := False;
while (pc <> rEndCode) and not Done do
begin
// reset decode parameters and save first code
if (pc = rClearCode) then
begin
rCurSize := rID^.rLZWSize + 1;
rCurSlot := rEndCode + 1;
rTopSlot := (1 shl rCurSize);
while (pc = rClearCode) do
pc := LZWGetCode;
if (pc = rEndCode) then
GIF_Error(13);
if (pc >= rCurSlot) then
pc := 0;
oc := pc;
LZWSaveCode(pc);
end
// find a code in the table and write out translation
else
begin
cc := pc;
if (cc < rCurSlot) then
begin
LZWDecodeCode(cc);
if (rCurSlot <= rTopSlot) then
begin
LZWSaveSlot(oc, cc);
oc := pc;
end;
LZWCheckSlot;
end
// add a new code to the decode table
else
begin
if (cc <> rCurSlot) then
GIF_Error(13);
tt := oc;
while (oc > rHighCode) do
oc := rPrefix[oc];
if (rCurSlot <= rTopSlot) then
LZWSaveSlot(tt, oc);
LZWCheckSlot;
LZWDecodeCode(cc);
oc := pc;
end;
end;
// write out translated bytes to the image storage
LZWWriteBitmap;
if fDataStream.Position < fDataStream.Size then
pc := LZWGetCode
else
Done := True;
rMaxVal := false;
end; // while not EOI
end; // with
// done with stack space
LZWFinit;
end;
{ ---------------------------------------------------------------------------- }
procedure TGif.LZWInit(pID: PGifImageDescriptor);
begin
// get a valid record?
if (pID = nil) then
GIF_Error(11);
// make sure we can actually decode this turkey
// if ((pID^.rLZWSize < 2) or (pID^.rLZWSize > 9)) then GIF_Error(12);
// allocate stack space
new(fZipData);
if (fZipData = nil) then
OutOfMemoryError;
// init data block
fillchar(fZipData^, sizeof(TGifZip), 0);
fZipData^.rID := pID;
fZipData^.rCT := fColorTableList.Items[pID^.rLocalColorTable];
// reset data stream
fDataStream.Position := 0;
end;
procedure TGif.LZWPutClear;
var
b: Byte;
begin
with fZipData^ do
begin
while (rBits > 0) do
begin
b := (rBitString and $FF);
rBitString := (rBitString shr 8);
rBits := rBits - 8;
fDataStream.Write(b, 1);
end;
end;
end;
procedure TGif.LZWPutCode(code: integer);
var
n: integer;
b: Byte;
begin
with fZipData^ do
begin
// write out finished bytes
// a literal "8" for 8 bits per byte
while (rBits >= 8) do
begin
b := (rBitString and $FF);
rBitString := (rBitString shr 8);
rBits := rBits - 8;
fDataStream.Write(b, 1);
end;
// make sure no junk bits left above the first byte
rBitString := (rBitString and $FF);
// and save out-going code
n := (Code shl rBits);
rBitString := (rBitString or n);
rBits := rBits + rCurSize;
end; // with
end;
{ ---------------------------------------------------------------------------- }
procedure TGif.LZWFinit;
begin
if (fZipData <> nil) then
dispose(fZipData);
fZipData := nil;
end;
{ ---------------------------------------------------------------------------- }
procedure TGif.LZWReset;
var
i: integer;
begin
with fZipData^ do
begin
for i := 0 to (kGifCodeTableSize - 1) do
begin
rPrefix[i] := 0;
rSuffix[i] := 0;
end;
rCurSize := rID^.rLZWSize + 1;
rClearCode := (1 shl rID^.rLZWSize);
rEndCode := rClearCode + 1;
rHighCode := rClearCode - 1;
rFirstSlot := (1 shl (rCurSize - 1)) + 2;
rNextSlot := rFirstSlot;
rMaxVal := false;
end; // with
end;
{ ---------------------------------------------------------------------------- }
{ get the next code from the BitString }
{ CurrentSize specifies the number of bits to get }
function TGif.LZWGetCode: integer;
var
n: integer;
cc: integer;
mask: integer;
b: byte;
begin
with fZipData^ do
begin
// make sure we have enough bits
while (rCurSize > rBits) do
begin
if (fDataStream.Position >= fDataStream.Size) then
b := 0
else
fDataStream.Read(b, 1);
n := b;
n := (n shl rBits); // scoot bits over to avoid previous data
rBitString := (rBitString or n); // put bits in the BitString
rBits := rBits + 8; // number of bits in a byte
end;
// get the code, then dump the bits we used from the BitString
case rCurSize of
0: mask := 0;
1: mask := $0001;
2: mask := $0003;
3: mask := $0007;
4: mask := $000F;
5: mask := $001F;
6: mask := $003F;
7: mask := $007F;
8: mask := $00FF;
9: mask := $01FF;
10: mask := $03FF;
11: mask := $07FF;
12: mask := $0FFF;
else
begin
GIF_Error(12);
Mask := 0; //stop warning
end;
end;
cc := (rBitString and mask); // mask off bits wanted
rBitString := (rBitString shr rCurSize); // delete bits we just took
rBits := rBits - rCurSize; // number of bits left in BitString
end; // with
// done
LZWGetCode := cc;
end;
{ ---------------------------------------------------------------------------- }
{ save a code value on the code stack }
procedure TGif.LZWSaveCode(Code: integer);
begin
with fZipData^ do
begin
rCodeStack[rSP] := Code;
rSP := rSP + 1;
end;
end;
{ ---------------------------------------------------------------------------- }
{ decode the CurrentCode into the clear-text pixel value }
{ mainly, just save the CurrentCode on the output stack, along with }
{ whatever prefixes go with it }
procedure TGif.LZWDecodeCode(var Code: integer);
begin
with fZipData^ do
begin
while (Code > rHighCode) do
begin
LZWSaveCode(rSuffix[Code]);
Code := rPrefix[Code];
end;
LZWSaveCode(Code);
end;
end;
procedure TGif.LZWEncode(pID: PGifImageDescriptor);
var
i, n: integer;
cc: integer; // current code to translate
oc: integer; // last code encoded
found: boolean; // decoded string in prefix table?
pixel: Byte; // lowest code to search for
ldx: integer; // last index found
fdx: integer; // current index found
begin
// allocate stack space
LZWInit(pID);
LZWReset;
// all within the data record
with fZipData^ do
begin
// reset output data stream
fDataStream.Clear;
// always save the clear code first ...
LZWPutCode(rClearCode);
// and first pixel
oc := LZWReadBitmap;
LZWPutCode(oc);
// nothing found yet (but then, we haven't searched)
// ldx := 0;
fdx := 0;
// and the rest of the pixels
rCount := 1;
while (rCount <= rID^.rPixelCount) do
begin
// empty the stack of old data
rSP := 0;
// next pixel from the bitmap
n := LZWReadBitmap;
LZWSaveCode(n);
cc := rCodeStack[0]; // beginning of the string
// add new encode table entry
rPrefix[rNextSlot] := oc;
rSuffix[rNextSlot] := cc;
rNextSlot := rNextSlot + 1;
if (rNextSlot >= kGifCodeTableSize) then
rMaxVal := True
else if (rNextSlot > (1 shl rCurSize)) then
rCurSize := rCurSize + 1;
// find the running string of matching codes
ldx := cc;
found := True;
while ((found) and (rCount <= rID^.rPixelCount)) do
begin
n := LZWReadBitmap;
LZWSaveCode(n);
// cc := rCodeStack[0];
if (ldx < rFirstSlot) then
i := rFirstSlot
else
i := ldx + 1;
pixel := rCodeStack[rSP - 1];
found := false;
while ((not found) and (i < rNextSlot)) do
begin
found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
i := i + 1;
end;
if (found) then
begin
ldx := i - 1;
fdx := i - 1;
end;
end; // while found
// if not found, save this index, and get the same code again
if (not found) then
begin
rUnget := True;
rLast := rCodeStack[rSP - 1];
rSP := rSP - 1;
cc := ldx;
end
else
begin
cc := fdx;
end;
// whatever we got, write it out as current table entry
LZWPutCode(cc);
if ((rMaxVal) and (rCount <= rID^.rPixelCount)) then
begin
LZWPutCode(rClearCode);
LZWReset;
cc := LZWReadBitmap;
LZWPutCode(cc);
oc := cc;
end
else
begin
oc := cc;
end;
end; // while pixelcount
LZWPutCode(rEndCode);
LZWPutClear;
end; // with
// done with stack space
LZWFinit;
end;
{ ---------------------------------------------------------------------------- }
{ save a new prefix/suffix pair }
procedure TGif.LZWSaveSlot(Prefix, Suffix: integer);
begin
with fZipData^ do
begin
rPrefix[rCurSlot] := Prefix;
rSuffix[rCurSlot] := Suffix;
rCurSlot := rCurSlot + 1;
end;
end;
{ ---------------------------------------------------------------------------- }
{ given current line number, compute the next line to be filled }
{ this gets a little tricky if an interlaced image }
{ what is the purpose of this interlace, anyway? it doesn't save space, }
{ and I can't imagine it makes for any faster image disply or loading }
procedure TGif.LZWIncrPosition;
var
n: integer;
begin
with fZipData^ do
begin
// if first pass, make sure CurPass was initialized
if (rCurPass = 0) then
rCurPass := 1;
// incr X position
rCurX := rCurX + 1;
// bumping Y ?
if (rCurX >= rID^.rWidth) then
begin
rCurX := 0;
// if not interlaced image, then just move down the page
if (not rID^.rInterlaced) then
begin
rCurY := rCurY + 1;
end
// interlaced images select the next line by some archane black-magical sheme
else
begin
case rCurPass of // delta to next row on this pass
1: n := 8;
2: n := 8;
3: n := 4;
4: n := 2;
else
begin
GIF_Error(21);
n := 0; //prevent warning
end;
end;
rCurY := rCurY + n;
// if past the end of the bitmap, start next pass
if (rCurY >= rID^.rHeight) then
begin
rCurPass := rCurPass + 1;
if (rCurPass = 5) then
rCurPass := 1;
case rCurPass of // first line for given pass
1: n := 0;
2: n := 4;
3: n := 2;
4: n := 1;
else
GIF_Error(21);
end;
rCurY := n;
end;
end;
end;
end; // with
end;
{ ---------------------------------------------------------------------------- }
{ see if it is time to add a new slot to the decoder tables }
procedure TGif.LZWCheckSlot;
begin
with fZipData^ do
begin
if (rCurSlot >= rTopSlot) then
begin
if (rCurSize < 12) then
begin
rTopSlot := (rTopSlot shl 1);
rCurSize := rCurSize + 1;
end
else
begin
rMaxVal := true;
end;
end;
end;
end;
{ ---------------------------------------------------------------------------- }
{ empty the Codes stack and write to the Bitmap }
procedure TGif.LZWWriteBitmap;
var
i, n: integer;
j: longint;
p: PByte;
begin
with fZipData^ do
begin
for n := (rSP - 1) downto 0 do
begin
rCount := rCount + 1;
// get next code from the stack, and index into PixelList
i := rCodeStack[n];
j := (rCurY * rID^.rWidth) + rCurX;
if ((0 <= j) and (j < rID^.rPixelCount)) then
begin
// store the pixel index into PixelList
p := PByte(PtrInt(rID^.rPixelList) + j);
p^ := Byte(i);
end;
LZWIncrPosition;
end;
rSP := 0;
end; // with
end;
{ ---------------------------------------------------------------------------- }
{ get the next pixel from the bitmap, and return it as an index into }
{ the colormap }
function TGif.LZWReadBitmap: integer;
var
n: integer;
j: longint;
p: PByte;
begin
with fZipData^ do
begin
if (rUnget) then
begin
n := rLast;
rUnget := false;
end
else
begin
rCount := rCount + 1;
j := (rCurY * rID^.rWidth) + rCurX;
if ((0 <= j) and (j < rID^.rPixelCount)) then
begin
p := PByte(PtrInt(rID^.rPixelList) + j);
n := ord(p^);
end
else
begin
n := 0;
end;
LZWIncrPosition;
end;
rLast := n;
end; // with
LZWReadBitmap := n;
end;
{ ---------------------------------------------------------------------------- }
{ PROCEDURES TO IMPLEMENT PROPERTIES ----------------------------------------- }
{ ---------------------------------------------------------------------------- }
function TGif.GetSignature: AnsiString;
var
s: AnsiString;
begin
s := fSignature^.rSignature;
GetSignature := s;
end;
{ ---------------------------------------------------------------------------- }
{ return screen descriptor data pointer, or set a new record block }
function TGif.GetScreenDescriptor: PGifScreenDescriptor;
begin
GetScreenDescriptor := fScreenDescriptor;
end;
{ ---------------------------------------------------------------------------- }
function TGif.GetImageCount: integer;
begin
GetImageCount := fImageDescriptorList.Count;
end;
function TGif.GetImageDescriptor(image: integer): PGifImageDescriptor;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then
GIF_Error(15);
GetImageDescriptor := fImageDescriptorList.Items[image];
end;
{ ---------------------------------------------------------------------------- }
function TGif.GetBitmap(image: integer): TBitmap;
var
p: PGifImageDescriptor;
b: TBitmap;
begin
p := GetImageDescriptor(image);
if (p^.rBitmap = nil) then
MakeBitmaps;
b := p^.rBitmap;
GetBitmap := b;
end;
{ ---------------------------------------------------------------------------- }
function TGif.GetColorTableCount: integer;
begin
GetColorTableCount := fColorTableList.Count;
end;
function TGif.GetColorTable(table: integer): PGifColorTable;
begin
if ((table < 0) or (table >= fColorTableList.Count)) then
GIF_Error(15);
GetColorTable := fColorTableList.Items[table];
end;
function TGif.GetImageDelay(Image: integer): integer;
var
gx: PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
begin
Result := gx^.rDelayTime;
if Result < 1 then
Result := 1;
end
else
Result := 1;
end;
function TGif.GetImageDisposal(Image: integer): integer;
var
gx: PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
Result := gx^.rDisposal and 3
else
Result := 0;
end;
{ ---------------------------------------------------------------------------- }
function TGif.GetColorIndex(image, x, y: integer): integer;
var
i, n: integer;
id: PGifImageDescriptor;
p: PByte;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then
GIF_Error(15);
id := fImageDescriptorList.Items[image];
if ((x < 0) or (x >= id^.rWidth)) then
GIF_Error(15);
if ((y < 0) or (y >= id^.rHeight)) then
GIF_Error(15);
n := (y * id^.rWidth) + x;
p := PByte(PtrInt(id^.rPixelList) + n);
i := ord(p^);
GetColorIndex := i;
end;
{ ---------------------------------------------------------------------------- }
{ transparent color for each individual image.
returns -1 if none. }
function TGif.GetTransparentIndex(image: integer): integer;
var
i: integer;
gx: PGifExtensionGraphic;
begin
i := -1;
gx := FindGraphicExtension(image);
if (gx <> nil) and (gx^.rTransparentValid) then {LDB}
i := gx^.rTransparentIndex;
GetTransparentIndex := i;
end;
{ ---------------------------------------------------------------------------- }
{ transparent color for all images }
{LDB Changed to always return the standard used for the transparent color}
function TGif.GetTransparentColor: TColor;
begin
GetTransparentColor := TransColor;
end;
procedure TGif.ExtractLoopCount(List: TList);
begin
if List.Count > 0 then
with PGifDataBlock(List[0])^ do
if rSize = 3 then
FLoopCount := rData[2] + rData[3] * 256;
end;
{ ---------------------------------------------------------------------------- }
function TGif.GetImageLeft(image: integer): integer;
var
id: PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageLeft := id^.rLeft;
end;
function TGif.GetImageTop(image: integer): integer;
var
id: PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageTop := id^.rTop;
end;
function TGif.GetImageWidth(image: integer): integer;
var
id: PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageWidth := id^.rWidth;
end;
function TGif.GetImageHeight(image: integer): integer;
var
id: PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageHeight := id^.rHeight;
end;
function TGif.GetImageDepth(image: integer): integer;
var
id: PGifImageDescriptor;
ct: PGifColorTable;
begin
id := GetImageDescriptor(image);
ct := fColorTableList.Items[id^.rLocalColorTable];
GetImageDepth := ct^.rSize;
end;
{ ---------------------------------------------------------------------------- }
{ GENERAL INTERNAL ROUTINES -------------------------------------------------- }
{ ---------------------------------------------------------------------------- }
procedure TGif.FreeDataBlockList(var list: TList);
var
i: integer;
db: PGifDataBlock;
begin
if (list <> nil) then
begin
for i := 0 to (list.Count - 1) do
begin
db := list.Items[i];
if (db <> nil) then
dispose(db);
end;
list.Free;
end;
list := nil;
end;
{ ---------------------------------------------------------------------------- }
procedure TGif.FreeExtensionList(var list: TList);
var
i: integer;
ex: PGifExtension;
begin
if (list <> nil) then
begin
for i := 0 to (list.Count - 1) do
begin
ex := list.Items[i];
if (ex <> nil) then
begin
if (ex^.rLabel = kGifLabelComment) then
FreeDataBlockList(ex^.rComment.rDataBlockList)
else if (ex^.rLabel = kGifLabelText) then
FreeDataBlockList(ex^.rText.rDataBlockList)
else if (ex^.rLabel = kGifLabelApplication) then
FreeDataBlockList(ex^.rApp.rDataBlockList);
dispose(ex);
end;
end;
list.Free;
end;
list := nil;
end;
{ ---------------------------------------------------------------------------- }
{ after an image has been LZW decoded, write a bitmap from the string of pixels }
{----------------TGif.MakeBitmaps}
procedure TGif.MakeBitmaps;
type
LayoutType = packed record
BFH: TBitmapFileHeader;
BIH: TBitmapInfoHeader;
end;
PLayoutType = ^LayoutType;
var
id: PGifImageDescriptor;
ct: PGifColorTable;
FullWidth, PixelSize, FileSize: integer;
Stream: TMemoryStream;
PL: PLayoutType;
Color: TColor;
Index: PtrInt;
Pix, P: PByte;
I, X, Y, N: integer;
TrIndex: integer;
begin
for i := 0 to (fImageDescriptorList.Count - 1) do
begin
id := fImageDescriptorList.Items[i];
if ((id <> nil) and (id^.rBitmap = nil)) then // don't do it again
with id^ do
begin
FullWidth := rWidth * 3;
if FullWidth and $3 <> 0 then
FullWidth := (FullWidth and $FFFFFFFC) + $4;
PixelSize := FullWidth * rHeight;
FileSize := Sizeof(LayoutType) + PixelSize;
Stream := TMemoryStream.Create;
try
Stream.Size := FileSize;
PL := Stream.Memory;
FillChar(PL^, FileSize, 0);
with PL^.BFH do
begin
bfType := 19778;
bfSize := FileSize;
bfReserved1 := 0;
bfReserved2 := 0;
bfOffBits := Sizeof(LayoutType);
end;
with PL^.BIH do
begin
biSize := Sizeof(TBitmapInfoHeader);
biWidth := rWidth;
biHeight := rHeight;
biPlanes := 1;
biBitCount := 24;
biCompression := 0;
biSizeImage := 0;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
ct := fColorTableList.Items[rLocalColorTable];
TrIndex := GetTransparentIndex(i);
if (TrIndex >= 0) and (TrIndex < ct^.rSize) then
{change transparent color to something that won't likely match any other color}
ct^.rColors[TrIndex] := TransColor;
N := 0;
Pix := PByte(PtrInt(PL) + Sizeof(LayoutType));
for Y := rHeight - 1 downto 0 do
begin
P := PByte(PtrInt(Pix) + (Y * FullWidth));
for X := 0 to rWidth - 1 do
begin
Index := PtrInt(PByte(PtrInt(rPixelList) + N)^);
Color := ct^.rColors[Index];
P^ := Byte((Color shr 16) and $FF);
Inc(P);
P^ := Byte((Color shr 8) and $FF);
Inc(P);
P^ := Byte(Color and $FF);
Inc(P);
Inc(N);
end;
end;
rBitmap := TBitmap.Create;
{$IFNDEF UseCLX}
rBitmap.HandleType := bmDIB;
{$ENDIF}
rBitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
// is bitmap transparent?
if ((0 <= TrIndex) and (TrIndex < ct^.rSize)) then
begin
rBitmap.Transparent := true;
rBitmap.TransparentMode := tmFixed;
rBitmap.TransparentColor := ct^.rColors[TrIndex];
end;
end;
end;
end;
{----------------TGif.GetStripBitmap}
type
ThtLayoutType = packed record
BFH: TBitmapFileHeader;
BIH: TBitmapInfoHeader;
end;
PLayoutType = ^ThtLayoutType;
{$ifdef LCL}
procedure CreateMask(Bitmap: TfrxHtBitmap; AColor: TColor);
var
IntfImage: TLazIntfImage;
x, y, stopx, stopy: Integer;
ImgHandle, MskHandle: HBitmap;
TransColor: TColor;
begin
// this convertion copied from TRasterImage.CreateMask() and modified:
IntfImage := TLazIntfImage.Create(0,0,[]);
try
MskHandle := CreateBitmap(Bitmap.Width, Bitmap.Height, 1, 1, nil);
IntfImage.LoadFromBitmap(Bitmap.BitmapMask.BitmapHandle, MskHandle);
DeleteObject(MskHandle);
stopx := IntfImage.Width - 1;
stopy := IntfImage.Height - 1;
if AColor <> clDefault then
TransColor := ColorToRGB(AColor)
else
TransColor := FPColorToTColor(IntfImage.Colors[0, stopy]);
for y := 0 to stopy do
for x := 0 to stopx do
IntfImage.Masked[x,y] := FPColorToTColor(IntfImage.Colors[x,y]) = TransColor;
IntfImage.CreateBitmaps(ImgHandle, MskHandle);
DeleteObject(ImgHandle);
Bitmap.BitmapMask.BitmapHandle := MskHandle;
finally
IntfImage.Free;
//Bitmap.Free;
end;
end;
{$endif}
function TGif.GetStripBitmap(): TfrxHtBitmap; {LDB}
{This is a single bitmap containing all the frames. A mask is also provided
if the GIF is transparent. Each Frame is set up so that it can be transparently
blted to a background.}
var
id: PGifImageDescriptor;
ct: PGifColorTable;
FullWidth, PixelSize, FileSize: integer;
Stream, MStream: TMemoryStream;
PL, MPL: PLayoutType;
Color: TColor;
Index: PtrInt;
Pix, P, MPix, MP, PRight: PByte;
I, X, Y, N: integer;
TrIndex: integer;
C: Byte;
IsTransparent: boolean;
begin
MStream := nil;
Result := nil;
MP := nil;
MPix := nil;
{find size needed for strip bitmap}
FullWidth := Width * 3 * ImageCount; {3 bytes per pixel}
if FullWidth and $3 <> 0 then {make sure it is DWord boundary}
FullWidth := (FullWidth and $FFFFFFFC) + $4;
PixelSize := FullWidth * Height;
FileSize := Sizeof(ThtLayoutType) + PixelSize;
if (FileSize > 200000000) or Transparent and (FileSize > 100000000) then
GIF_Error(25);
Stream := TMemoryStream.Create;
try
Stream.Size := FileSize;
PL := Stream.Memory;
FillChar(PL^, FileSize, 0);
with PL^.BFH do
begin {set up the bitmap file header}
bfType := 19778;
bfSize := FileSize;
bfReserved1 := 0;
bfReserved2 := 0;
bfOffBits := Sizeof(ThtLayoutType);
end;
with PL^.BIH do
begin {and the bitmap info header}
biSize := Sizeof(TBitmapInfoHeader);
biWidth := Width * ImageCount;
biHeight := Height;
biPlanes := 1;
biBitCount := 24; {will use 24 bit pixel}
biCompression := 0;
biSizeImage := 0;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
end;
Pix := PByte(PtrInt(PL) + Sizeof(ThtLayoutType)); {where pixels start}
IsTransparent := Transparent;
if IsTransparent then
begin {set up a mask similarly}
MStream := TMemoryStream.Create;
MStream.Size := FileSize;
MPL := MStream.Memory;
Move(PL^, MPL^, FileSize); {for now, this is a direct copy}
MPix := PByte(PtrInt(MPL) + Sizeof(ThtLayoutType)); {where mask pixels start}
FillChar(MPix^, PixelSize, $FF); {Need to make first frame totally transparent}
end;
for i := 0 to (fImageDescriptorList.Count - 1) do {for all the frames}
begin
id := fImageDescriptorList.Items[i];
if (id <> nil) then
with id^ do
begin
ct := fColorTableList.Items[rLocalColorTable];
TrIndex := GetTransparentIndex(i);
N := 0; {pixel index in rPixelList, the frame source pixels}
for Y := Height - 1 downto Math.Max(Height - rHeight, ImageTop[I]) do
begin
{find the start of each frame row in destination. Note that the source
frame may be smaller than the destination and positioned according to
imagetop and imageleft}
P := PByte(PtrInt(Pix) + ((Y - ImageTop[i]) * FullWidth) + i * Width * 3 + ImageLeft[i] * 3);
PRight := PByte(PtrInt(P) + Width * 3);
if IsTransparent then {same for mask}
MP := PByte(PtrInt(MPix) + ((Y - ImageTop[i]) * FullWidth) + i * Width * 3 + ImageLeft[i] * 3);
for X := 0 to rWidth - 1 do
begin
if PtrInt(P) < PtrInt(PRight) then {prevent write beyond proper right side in case rwidth to wide}
begin
Index := PtrInt(PByte(PtrInt(rPixelList) + N)^); {Source pixel index in colortable}
Color := ct^.rColors[Index]; {its color}
{for frames after the 0th, only the non transparent pixels are written
as writing transparent ones might cover results copied from the previous frame}
if (Index <> trIndex) then
begin
P^ := Byte((Color shr 16) and $FF);
Inc(P);
P^ := Byte((Color shr 8) and $FF);
Inc(P);
P^ := Byte(Color and $FF);
Inc(P);
end
else if i = 0 then
begin {transparent pixel, first frame, write black}
P^ := 0;
Inc(P);
P^ := 0;
Inc(P);
P^ := 0;
Inc(P);
end
else
Inc(P, 3); {ignore transparent pixel}
if IsTransparent then {also do the mask}
begin
if Index = trIndex then
C := $FF {transparent part is white}
else
C := 0; {non transparent is black}
{again for frames after the 0th, only non-transparent pixels are written}
if (i = 0) or (C = 0) then
begin
MP^ := C;
Inc(MP);
MP^ := C;
Inc(MP);
MP^ := C;
Inc(MP);
end
else
Inc(MP, 3);
end;
end;
Inc(N); {bump source pixel index}
end;
end;
end;
{Now copy this frame to the next (unless it the last one). This serves as a
background for the next image. This is all that's needed for the dtDoNothing
disposal method but will be fixed up for dtBackground below}
if (i < fImageDescriptorList.Count - 1) then
begin
for Y := Height - 1 downto 0 do
begin {copy line by line}
P := PByte(PtrInt(Pix) + (Y * FullWidth) + i * Width * 3);
if IsTransparent then
MP := PByte(PtrInt(MPix) + (Y * FullWidth) + i * Width * 3);
Move(P^, PByte(PtrInt(P) + Width * 3)^, Width * 3);
if IsTransparent then
Move(MP^, PByte(PtrInt(MP) + Width * 3)^, Width * 3);
end;
{for dtBackground, fill the mask area occupied by the current copied image with
white. This makes it transparent so the original background will appear here
(although the next image will no doubt write on part of this area.}
if IsTransparent and (ImageDisposal[i] in [2, 3]) then {dtToPrevious run as dtBackground as it seems other browsers do this}
with id^ do
for Y := Height - 1 downto Math.Max(Height - rHeight, ImageTop[I]) do
begin
MP := PByte(PtrInt(MPix) + ((Y - ImageTop[i]) * FullWidth) + (i + 1) * Width * 3 + ImageLeft[i] * 3);
FillChar(MP^, rWidth * 3, $FF);
end;
end;
end;
Result := TfrxHtBitmap.Create(IsTransparent);
{$IFNDEF UseCLX}
Result.HandleType := bmDIB;
{$ENDIF}
Result.LoadFromStream(Stream); {turn the stream just formed into a TBitmap}
if IsTransparent then
begin
Result.HandleType := bmDIB;
Result.BitmapMask.LoadFromStream(MStream);
{$ifdef LCL}
// setting to monochrome not yet implemented
CreateMask(Result, clWhite);
{$else}
Result.BitmapMask.Monochrome := True; {crunch mask into a monochrome TBitmap}
{$endif}
end;
Stream.Free;
MStream.Free;
except
Stream.Free;
MStream.Free;
Result.Free;
raise;
end;
end;
{ ---------------------------------------------------------------------------- }
{ find the graphic extension for an image }
function TGif.FindGraphicExtension(image: integer): PGifExtensionGraphic;
var
n: integer;
id: PGifImageDescriptor;
ex: PGifExtension;
gx: PGifExtensionGraphic;
begin
gx := nil;
id := fImageDescriptorList.Items[image];
if (id^.rExtensionList <> nil) then
begin
for n := 0 to (id^.rExtensionList.Count - 1) do
begin
ex := id^.rExtensionList.Items[n];
if ((ex^.rLabel = kGifLabelGraphic) and (gx = nil)) then
begin
gx := @(ex^.rGraphic);
end;
end;
end;
FindGraphicExtension := gx;
end;
{ ---------------------------------------------------------------------------- }
{ find the color within the color table; returns 0..255 }
{ return -1 if color not found }
function TGif.FindColorIndex(c: TColor; ct: PGifColorTable): integer;
var
i, n: integer;
begin
n := -1;
for i := 0 to (ct^.rSize - 1) do
begin
if ((n < 0) and (ct^.rColors[i] = c)) then
n := i;
end;
FindColorIndex := n;
end;
{ ThtBitmap }
function TfrxHtBitmap.GetMask: TBitmap;
{This returns mask for frame 1. Content is black, background is white}
begin
if not FTransparentMask then
Result := nil
else
Result := FMask;
end;
procedure TfrxHtBitmap.SetTransparentMask(AValue: Boolean);
begin
if FTransparentMask <> AValue then
begin
FTransparentMask := AValue;
if not FTransparentMask then
FreeAndNil(FMask)
else if FMask = nil then
begin
FMask := TfrxHtBitmap.Create;
FMask.TransparentMode := tmFixed;
FMask.TransparentColor := clNone;
end;
end;
end;
constructor TfrxHtBitmap.Create(WithTransparentMask: Boolean);
begin
inherited Create;
SetTransparentMask( WithTransparentMask );
end;
procedure TfrxHtBitmap.Assign(Source: TPersistent);
var
htSource: TfrxHtBitmap absolute Source;
begin
{$ifdef LCL}
// LCL didn't copy PixelFormat before SVN-33344 (2011-11-05)
if Source is TCustomBitmap then
PixelFormat := TCustomBitmap(Source).PixelFormat;
{$endif}
inherited;
if Source is TfrxHtBitmap then
begin
FTransparentMask := htSource.FTransparentMask;
SetMask(htSource.FMask);
end;
end;
destructor TfrxHtBitmap.Destroy;
begin
FMask.Free;
inherited;
end;
procedure TfrxHtBitmap.SetMask(AValue: TBitmap);
begin
if AValue = nil then
FreeAndNil(FMask)
else
begin
if FMask = nil then
begin
FMask := TfrxHtBitmap.Create;
FMask.TransparentMode := tmFixed;
FMask.TransparentColor := clNone;
end;
FMask.Assign(AValue);
end;
end;
procedure TfrxHtBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
StretchDraw(ACanvas, Rect, Bounds(0, 0, Width, Height));
end;
procedure TfrxHtBitmap.StretchDraw(ACanvas: TCanvas; const DestRect, SrcRect: TRect);
{Draw parts of this bitmap on ACanvas}
{$ifdef LCL}
var
UseMaskHandle: HBitmap;
SrcDC: hDC;
DestDC: hDC;
begin
if (Width=0) or (Height=0)
then Exit;
BitmapHandleNeeded;
if not BitmapHandleAllocated then Exit;
if TransparentMask then
UseMaskHandle := FMask.Handle
else
UseMaskHandle := 0;
SrcDC := Canvas.GetUpdatedHandle([csHandleValid]);
ACanvas.Changing;
DestDC := ACanvas.GetUpdatedHandle([csHandleValid]);
StretchMaskBlt(
DestDC, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
SrcDC, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
UseMaskHandle, SrcRect.Left, SrcRect.Top, ACanvas.CopyMode);
ACanvas.Changed;
end;
{$else LCL}
var
OldPalette: HPalette;
RestorePalette: Boolean;
DoHalftone: Boolean;
Pt: TPoint;
BPP: Integer;
begin
PaletteNeeded;
OldPalette := 0;
RestorePalette := False;
if Palette <> 0 then
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, True);
RealizePalette(ACanvas.Handle);
RestorePalette := True;
end;
BPP := GetDeviceCaps(ACanvas.Handle, BITSPIXEL) *
GetDeviceCaps(ACanvas.Handle, PLANES);
DoHalftone := (BPP <= 8) and (PixelFormat in [pf15bit, pf16bit, pf24bit]);
if DoHalftone then
begin
GetBrushOrgEx(ACanvas.Handle, pt);
SetStretchBltMode(ACanvas.Handle, HALFTONE);
SetBrushOrgEx(ACanvas.Handle, pt.x, pt.y, @pt);
end
else if not Monochrome then
SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
try
if FTransparentMask then
TransparentStretchBlt(
ACanvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
Canvas.Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
FMask.Canvas.Handle, SrcRect.Left, SrcRect.Top) {LDB}
else
StretchBlt(
ACanvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
Canvas.Handle, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
ACanvas.CopyMode);
finally
if RestorePalette then
SelectPalette(ACanvas.Handle, OldPalette, True);
end;
end;
{$endif LCL}
{ ---------------------------------------------------------------------------- }
{ RAISE AN ERROR ------------------------------------------------------------- }
procedure GIF_Error(n: integer);
begin
GIF_ErrorCode := n;
GIF_ErrorString := kGifErrorMessages[n];
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
end;
procedure GIF_ErrorMessage(m: string);
begin
GIF_ErrorCode := 6;
GIF_ErrorString := m;
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
end;
end.
Reference in New Issue Copy Permalink