jvqgif.pas

East make Tray Icon in delphi

{******************************************************************************}
{* WARNING:  JEDI VCL To CLX Converter generated unit.                        *}
{*           Manual modifications will be lost on next release.               *}
{******************************************************************************}

{-----------------------------------------------------------------------------
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.sourceforge.net

Known Issues:
  GIF support is native for VisualCLX so this file is VCL only
-----------------------------------------------------------------------------}
// $Id: JvQGIF.pas,v 1.2 2004/05/28 20:26:21 asnepvangers Exp $

{$I jvcl.inc}
{$I vclonly.inc}

// for HeapAllocFlags
{$WARN SYMBOL_PLATFORM OFF}

unit JvQGIF;

interface

uses
  Windows, 
  RTLConsts, 
  SysUtils, Classes, Types, QGraphics, QControls;

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;
    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 GetTransparent: Boolean;override;
    procedure ClearItems;
    procedure NewImage;
    procedure UniqueImage;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
    property Bitmap: TBitmap read GetBitmap; { volatile }
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear;
    procedure DecodeAllFrames;
    procedure EncodeAllFrames;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override; 
    procedure LoadFromResourceName(Instance: THandle; const ResName: string;
      ResType: PChar);
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer;
      ResType: PChar);
    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
    constructor Create(AOwner: TJvGIFImage); virtual;
    procedure LoadFromStream(Stream: TStream);
    procedure AssignTo(Dest: TPersistent); override;
    procedure GrayscaleImage(ForceEncoding: Boolean);
  public
    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(TSharedImage)
  private
    FComment: TStringList;
    FAspectRatio: Byte;
    FBitsPerPixel: Byte;
    FColorResBits: Byte;
    FColorMap: TGIFColorTable;
  protected
    procedure FreeHandle; override;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TGIFItem = class(TSharedImage)
  private
    FImageData: TMemoryStream;
    FSize: TPoint;
    FPackedFields: Byte;
    FBitsPerPixel: Byte;
    FColorMap: TGIFColorTable;
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

var
  CF_GIF: Word; { 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
  QConsts, Math,
  JvQJCLUtils, JvQJVCLUtils, JvQAni, JvQConsts, JvQResources, JvQTypes;

{$R-}

procedure JvGif_Dummy;
begin
end;

procedure GifError(const Msg: string);

  function ReturnAddr: Pointer;
  asm
          MOV     EAX,[EBP+4]
  end;

begin
  raise EInvalidGraphicOperation.Create(Msg) at ReturnAddr;
end;

{$IFDEF RANGECHECKS_ON}
{$R+}
{$ENDIF RANGECHECKS_ON}

//=== TSharedImage ===========================================================

const
  GIFSignature = 'GIF';
  GIFVersionStr: array [TGIFVersion] of PChar = (#0#0#0, '87a', '89a');

function GIFVersionName(Version: TGIFVersion): string;
begin
  Result := StrPas(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: array [0..2] of Char; { contains 'GIF' }
    Version: array [0..2] of Char; { '87a' or '89a' }
  end;

  TScreenDescriptor = packed record
    ScreenWidth: Word; { logical screen width }
    ScreenHeight: Word; { logical screen height }
    PackedFields: Byte;
    BackgroundColorIndex: Byte; { Index to global color table }
    AspectRatio: Byte; { actual ratio = (AspectRatio + 15) / 64 }
  end;

  TImageDescriptor = packed record
    ImageLeftPos: Word; { column in pixels in respect to left of logical screen }
    ImageTopPos: Word; { row in pixels in respect to top of logical screen }
    ImageWidth: Word; { width of image in pixels }
    ImageHeight: Word; { height of image in pixels }
    PackedFields: Byte;
  end;

{ GIF Extensions support }

type
  TExtensionType = (etGraphic, etPlainText, etApplication, etComment);

const
  ExtLabels: array [TExtensionType] of Byte = ($F9, $01, $FF, $FE);
  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: