gifunit.pas

Delphi direct support for GIF files

unit GifUnit;
{ Exports TGifFile and TGifSubImage classes.

Needs non-VCL units:
- ColorTbl, DynArrB, GifDecl:
  belonging to the 'core' of the gif library
- HeapUnit (only if Delphi 1 is used)
- MoreUtil, Progress:
  general purpose units; can be left out if necessary
- FmProgr, FmCanSav:
  forms that are used by MoreUtil and Progress
The latter four can be easily left out if necessary.

by Reinier Sterkenburg (February-November 1997)
   [e-mail]
   www.dataweb.nl/~r.p.sterkenburg

Known bugs / left to do: see the VERSIONS.TXT file

Before using the GIF format in any commercial application
be sure you know the legal issues for this format!

Versions (for older versions see the file versions.txt):
10 Mar 97: - first version (1.00) released by uploading it to
             the Delphi Super Page (freeware)
17 Mar 97: - moved the comments about older version
             to separate file (versions.txt)
           - added TGifSubImage.Destroy and TGifImage.Destroy
18 Mar 97: - made the unit also work under Delphi 1.0, by changing the type
             of the 'CompressedRasterData' from a huge string into
             a specially made TEncodedBytes/TByteBuffer (see unit GifDecl);
             also made some obvious D2-D1 modifications involving
             SetLength, Application.Initialize, and the use of Longint
 3 Apr 97: - renamed AsTBitmap to AsBitmap
           - Made AsBitmap also a method of TGifSubImage;
             added field FGifImage to TGifSubImage;
             moved SaveToStream from TGifFile to TGifSubImage
 5 Apr 97: - added FBitmap as field to TGifSubImage, for speed advantage
13 Apr 97: - Made animation extension work, through functions AnimateInterval;
             see also unit GifImgs (with TGifImage)
           - released this version as version 2.00
24 Jul 97: - added comment: two bugs found by users:
             - reset of read-only files
           - Corrected a bug: number of colors in Localcolormap
             now assigned
 2 Aug 97: - Solved two memory leaks (LineBytes objects were not freed)
           - added try-except block which catches EListError in
             TGifImage.DecodeRasterData. It seems that some Gif-creating
             software leaves out the rest of the pixels when they are all
             zero. Now these files can also be read and displayed successfully.
           - EStringlistError also caught to get it also to work in Delphi 3
14 Aug 97: - PixelString is now a TByteBuffer in stead of a string.
             This solves a bug that occurred in Delphi 1 when strings
             became longer than 255 characters
23 Aug 97: - Made procedure BitmapToPixelmatrix a lot (roughly four times)
             faster by making use of the ScanLine property of TBitmap;
             this works for Delphi 3 only
           - Struggled with GetPixel(H, x, y) but it won't work much
             faster when ShowProgress is used. I keep using ShowProgress.
31 Aug 97: - Added checks on 'Eof(infile)' at a few places. Also one
             BlockRead call in ReadRasterData got an extra parameter.
             As far as I know, this  shouldn't be necessary for Gif files
             that follow the Gif specification, but this extra check does
             make it possible to read certain gif files that otherwise cause
             errors.
           - Deleted TGifSubImage.Copy. It wasn't used and only caused
             annoying hints.
13 Sep 97: - Applied fix (FileMode := 0) in initialization (Delphi 2 only)
             so opening read-only files won't give errors anymore
           - Added LoadFromStream methods (replacing a.o. LoadFromOpenInfile);
             removed all use of 'infile' using 'Stream' instead
           - Added TGifBitmap and RegisterFileFormat (thanks to Eric Maddox
             who supplied the piece of code that does this)
           - deleted BitmapRToPixelmatrix from interface;
             not used by GifImg anymore
29 Oct 97: - Moved memory compiler directive ($M) from demo .dpr files
             to this unit.
 3 Nov 97: - fixed most of the memory leakages; only Freeing extensions
             is not yet done
 5 Nov 97: - Deleted the remains (commented out) of the file-reading
             and -writing stuff. It had been replaced with Stream reading
             and writing.
           - added try-finally block in TGifSubImage.DecodeRasterData
             to ensure freeing of LineBytes
           - Deleted ReadColor (it wasn't used)
 9 Nov 97: - made Extensions of type TExtensionList in stead of TList
           - Moved memory compiler directive ($M) back from
             this unit to demo .dpr files after finding out that it
             has no effect in units
           - ifdef'd out the warnings that are displayed when
             animation time intervals are not present or not equal
14 Nov 97: - added TPicture.UnRegisterGraphicClass in finalization section
             This fixes a GPF that occurs when a package containing the GIF
             code is reloaded
 2 Dec 97: - added IsTransparent
29 Dec 97: - added GrabScreen
 3 Jan 98: - converted a few fields of TGifSubImage to properties:
             Extensions, IsTransparent, and added DisposalMethod
12 Feb 98: - added TGifSubImage.BackgroundColor
13 Feb 98: - deleted unused stuff
17 Feb 98: - declared DrawingTransparent as a const in stead of a var
           - added GifDecl specifier before declarations of TExtension instances
}
{$ifdef ver100}
{$define UseScanlines}
{$endif}

interface

uses
  WinProcs,        { Imports RGB }
  WinTypes,        { Imports TBitmapInfoHeader }
{ declared these Windows units before Graphics so
  TBitmap from Graphics is used }
  Classes,         { Imports TList }
  ColorTbl,        { Imports TColorTable }
  Controls,        { Imports Cursor values }
  Dialogs,         { Imports ShowMessage }
  DynArrB,         { Imports TByteArray2D }
  Forms,           { Imports Screen }
  GifDecl,         { Imports constant and type declarations }
  Graphics,        { Imports TColor }
  MoreUtil,        { Imports WarningMessage }
  Progress,        { Imports ShowProgress }
  SysUtils;        { Imports UpperCase }

type
  TGifFile = class;
  TGifSubImage = class(TObject)
  private
    LZWCodeSize: Byte;
    CompressedRasterData: TByteBuffer;

    FGifFile: TGifFile;
    FBitmap: TBitmap;
    FDisposalMethod: TDisposalMethod;
    FExtensions: TExtensionList;
    FIsTransparent: Boolean;
    { property acess methods }
    function  GetAnimateInterval: Word;
    function  GetBGColor: TColor;
    procedure SetAnimateInterval(NewValue: Word);
    procedure SetExtensions(NewValue: TExtensionList);
    { other private methods }
    procedure DecodeStatusbyte;
    procedure ReadImageDescriptor(Stream: TStream);
    procedure ReadLocalColorMap(Stream: TStream);
    procedure ReadRasterData(Stream: TStream);
    procedure DecodeRasterData;
    procedure LoadFromStream(Stream: TStream);

    procedure WriteImageDescriptor(Stream: TStream);
    procedure WriteLocalColorMap(Stream: TStream);
    procedure EncodeRasterdata;
    procedure WriteRasterData(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
  public
    ImageDescriptor: TImageDescriptor;
    Interlaced: Boolean;
    HasLocalColorMap: Boolean;
    BitsPerPixel: Byte;
    Pixels: TByteArray2D;
    LocalColorMap: TColorTable;

    constructor Create(NColors: Word; Parent: TGifFile);
    constructor CreateEmpty;
    destructor Destroy; override;

    function  AsBitmap: TBitmap;
    procedure EncodeStatusbyte;
    function  TransparentColor: TColor;
    function  TransparentColorIndex: Integer;

    property  AnimateInterval: Word
              read GetAnimateInterval
              write SetAnimateInterval;
    property  BackgroundColor: TColor
              read GetBGColor;
    property  Extensions: TExtensionList
              read FExtensions
              write SetExtensions;
    property  DisposalMethod: TDisposalMethod
              read FDisposalMethod;
    property  IsTransparent: Boolean
              read FIsTransparent;
  end; { TGifSubImage }

  TGifFile = class(TObject)
  private
    procedure DecodeStatusByte;
    procedure ReadExtensionBlocks(Stream: TStream;
                                  var SeparatorChar: Char;
                                  var Extensions: TExtensionList);
    procedure ReadSignature(Stream: TStream);
    procedure ReadScreenDescriptor(Stream: TStream);
    procedure ReadGlobalColorMap(Stream: TStream);

    procedure EncodeGifFile;
    procedure EncodeStatusByte;
    procedure WriteSignature(Stream: TStream);
    procedure WriteScreenDescriptor(Stream: TStream);
    procedure WriteGlobalColorMap(Stream: TStream);
  public
    Header: TGifHeader;
    ScreenDescriptor: TLogicalScreenDescriptor;
    HasGlobalColorMap: Boolean;
    GlobalColorMap: TColorTable;
    BitsPerPixel: Byte;
    SubImages: TList;
    constructor Create;
    destructor Destroy; override;
    procedure AddBitmap(Bitmap: TBitmap);
    function  AsBitmap: TBitmap;
    function  GetSubImage(Index: Integer): TGifSubImage;
    procedure LoadFromFile(filename: String);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(filename: String);
    procedure SaveToStream(Stream: TStream);
  end; { TGifFile }

type
  TGifBitmap = class(TBitmap)
  public
    procedure LoadFromStream(Stream: TStream); override;
  end; { TGifBitmap }


procedure DrawTransparent(DestCanvas: TCanvas; X, Y: smallint;
                          SrcBitmap: TBitmap; AColor: TColor);
{ Draws SrcBitmap on the DestCanvas, with AColor as transparent color.
Subroutine was posted by Leif L. in Borland's Delphi.Graphics newsgroup
and is thankfully used }

procedure GrabScreen(const SourceRect: TRect; Bitmap: TBitmap);
{ Captures what's on the screen in the SourceRect rectangle into
the Bitmap bitmap.
Posted in Borland's Delphi.Graphics newsgroup by Nick Hodges;
he refers to Mike Scott as the creator }

const
  DrawingTransparent: Boolean = False;

implementation

procedure DrawTransparent(DestCanvas: TCanvas; X, Y: smallint;
                          SrcBitmap: TBitmap; AColor: TColor);
{ Draws SrcBitmap on the DestCanvas, with AColor as transparent color.
Subroutine was posted by Leif L. in Borland's Delphi.Graphics newsgroup
and is thankfully used }
var
  ANDBitmap, ORBitmap: TBitmap;
  CM: TCopyMode;
  Src: TRect;
begin { DrawTransparent }
  DrawingTransparent := True;
  ANDBitmap := nil;
  ORBitmap := nil;
  try
    ANDBitmap := TBitmap.Create;
    ORBitmap := TBitmap.Create;
    Src  := Bounds(0, 0, SrcBitmap.Width, SrcBitmap.Height);
    with ORBitmap
    do begin
      Width := SrcBitmap.Width;
      Height := SrcBitmap.Height;
      Canvas.Brush.Color := clBlack;
      Canvas.CopyMode := cmSrcCopy;
      Canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
    end;
    with ANDBitmap
    do begin
      Width := SrcBitmap.Width;
      Height := SrcBitmap.Height;
      Canvas.Brush.Color := clWhite;
      Canvas.CopyMode := cmSrcInvert;
      Canvas.BrushCopy(Src, SrcBitmap, Src, AColor);
    end;
    with DestCanvas
    do begin
      CM := CopyMode;
      CopyMode := cmSrcAnd;
      Draw(X, Y, ANDBitmap);
      CopyMode := cmSrcPaint;
      Draw(X, Y, ORBitmap);
      CopyMode := CM;
    end;
  finally
    ANDBitmap.Free;
    ORBitmap.Free;
  end;
  DrawingTransparent := False;
end;  { DrawTransparent }

procedure GrabScreen(const SourceRect: TRect; Bitmap: TBitmap);
{ Captures what's on the screen in the SourceRect rectangle into
the bitmap }
var ScreenCanvas: TCanvas ;
begin { GrabScreen }
  ScreenCanvas := TCanvas.Create;
  try
    ScreenCanvas.Handle := GetDC(0);
    try
      Bitmap.Width := SourceRect.Right - SourceRect.Left;
      Bitmap.Height := SourceRect.Bottom - SourceRect.Top;
      Bitmap.Canvas.CopyRect( Rect(0, 0, Bitmap.Width, Bitmap.Height),
                              ScreenCanvas, SourceRect);
    finally
      ReleaseDC( 0, ScreenCanvas.Handle);
      ScreenCanvas.Handle := 0;
    end;
  finally
    ScreenCanvas.Free;
  end;
end;  { GrabScreen }

function PaletteToDIBColorTable(Pal: HPalette;
                 var ColorTable: array of TRGBQuad): Integer;
{ This function was found in the Graphics unit but it is not exported.
  It's modified: ByteSwapColors is not called because a TRGBQuad
  has the same physical layout as TColor }
begin { PaletteToDIBColorTable }
  Result := 0;
  if (Pal = 0) or
     (GetObject(Pal, sizeof(Result), @Result) = 0) or
     (Result = 0)
  then Exit;
  if Result > High(ColorTable)+1
  then Result := High(ColorTable)+1;
  GetPaletteEntries(Pal, 0, Result, ColorTable);
end;  { PaletteToDIBColorTable }

{$ifdef UseScanlines}
procedure BitmapToPixelmatrix8bpp(Bitmap: TBitmap;
                                  var ColorTable: TColorTable;
                                  var Pixels: TByteArray2D);
{ Converts the pixels of a TBitmap into a matrix of pixels (PixelArray)
and constructs the Color table in the same process.
This '8bpp' variant makes use of the ScanLine property of TBitmap
(appl. since Delphi 3.0) AND assumes 1 pixel =1 byte (8 bits per pixel) }
var
  i, j: Integer;
  SL: PByteArray;
  PaletteIndex: Byte;
  PixelValRGBQuad: TRGBQuad;
  PixelVal: TColor absolute PixelValRGBQuad;
  ColorIndex: Integer;
  ColorQuadTable: array[0..255] of TRGBQuad;
begin { BitmapToPixelmatrix8bpp }
  ColorTable.Count := 0;
  PaletteToDIBColorTable(Bitmap.Palette, ColorQuadTable);
  with Bitmap
  do begin
    Pixels := TByteArray2D.Create(Width, Height);
    ShowProgress(0);
    for j := 1 to Height
    do begin
      SL := Bitmap.Scanline[j-1];
      for i := 1 to Width
      do begin
        PaletteIndex := SL[i-1];
        PixelValRGBQuad := ColorQuadTable[PaletteIndex];
        ColorIndex := ColorTable.GetColorIndex(PixelVal);
        if ColorIndex = -1
        then begin
          ColorTable.FCT.Colors[ColorTable.Count] := PixelVal;
          ColorIndex := ColorTable.Count;
          ColorTable.Count := ColorTable.Count + 1; { no check on > 256 yet }
        end;
        Pixels[i, j] := ColorIndex;
      end;
      ShowProgress(j/Height)
    end;
  end; { with }
  ColorTable.AdjustColorCount;
  ColorTable.CompactColors;
end;  { BitmapToPixelmatrix8bpp }
{$endif UseScanlines}

procedure BitmapToPixelmatrix(Bitmap: TBitmap;
                              var ColorTable: TColorTable;
                              var Pixels: TByteArray2D);
{ Converts the pixels of a TBitmap into a matrix of pixels (PixelArray)
and constructs the Color table in the same process. }
var
  H: HDC;
  i, j: Integer;
  PixelVal: TColor;
  PrevPixelVal: TColor;
  ColorIndex: Integer;
begin { BitmapToPixelmatrix }
  ColorTable := TColorTable.Create(0);
{$ifdef UseScanlines}
  if Bitmap.PixelFormat in [pf15bit, pf16bit, pf24bit, pf32bit]
  then begin
    Bitmap.PixelFormat := pf8bit;
    ShowMessage('Warning: the bitmap color depth is more than 8 bits per pixel'
      +#13+#10+'This is now converted to 8 bits per pixel');