gifimage.pas

用Delphi 开发的一个 户籍管理系统

{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE VER15_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$ENDIF}
// 2003.03.09 <-

////////////////////////////////////////////////////////////////////////////////
//
//		Compiler Options required to compile this library
//
////////////////////////////////////////////////////////////////////////////////
{$A+,B-,H+,J+,K-,M-,T-,X+}

// Debug control - You can safely change these settings
{$IFDEF DEBUG}
{$C+} // ASSERTIONS
{$O-} // OPTIMIZATION
{$Q+} // OVERFLOWCHECKS
{$R+} // RANGECHECKS
{$ELSE}
{$C-} // ASSERTIONS
{$IFDEF GIF_NOSAFETY}
{$Q-} // OVERFLOWCHECKS
{$R-} // RANGECHECKS
{$ENDIF}
{$ENDIF}

// Special options for Time2Help parser
{$IFDEF TIME2HELP}
{$UNDEF PIXELFORMAT_TOO_SLOW}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//			External dependecies
//
////////////////////////////////////////////////////////////////////////////////
uses
  sysutils,
  Windows,
  Graphics,
  Classes;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFImage library version
//
////////////////////////////////////////////////////////////////////////////////
const
  GIFVersion = $0202;
  GIFVersionMajor = 2;
  GIFVersionMinor = 2;
  GIFVersionRelease = 5;

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			Misc constants and support types
  //
  ////////////////////////////////////////////////////////////////////////////////
const
  GIFMaxColors = 256; // Max number of colors supported by GIF
  // Don't bother changing this value!

  BitmapAllocationThreshold = 500000; // Bitmap pixel count limit at which
  // a newly allocated bitmap will be
                                   // converted to 1 bit format before
                                   // being resized and converted to 8 bit.

var
{$IFDEF FAST_AS_HELL}
  GIFDelayExp: integer = 10; // Delay multiplier in mS.
{$ELSE}
  GIFDelayExp: integer = 12; // Delay multiplier in mS. Tweaked.
{$ENDIF}
  // * GIFDelayExp:
    // The following delay values should all
                                     // be multiplied by this value to
                                     // calculate the effective time (in mS).
                                     // According to the GIF specs, this
                                     // value should be 10.
                                     // Since our paint routines are much
                                     // faster than Mozilla's, you might need
                                     // to increase this value if your
                                     // animations loops too fast. The
                                     // optimal value is impossible to
                                     // determine since it depends on the
                                     // speed of the CPU, the viceo card,
                                     // memory and many other factors.

  GIFDefaultDelay: integer = 10; // * GIFDefaultDelay:
  // Default animation delay.
  // This value is used if no GCE is
                                   // defined.
                                   // (10 = 100 mS)

{$IFDEF FAST_AS_HELL}
  GIFMinimumDelay: integer = 1; // Minimum delay (from Mozilla source).
  // (1 = 10 mS)
{$ELSE}
  GIFMinimumDelay: integer = 3; // Minimum delay - Tweaked.
{$ENDIF}
  // * GIFMinimumDelay:
  // The minumum delay used in the Mozilla
                                     // source is 10mS. This corresponds to a
                                     // value of 1. However, since our paint
                                     // routines are much faster than
                                     // Mozilla's, a value of 3 or 4 gives
                                     // better results.

  GIFMaximumDelay: integer = 1000; // * GIFMaximumDelay:
  // Maximum delay when painter is running
  // in main thread (goAsync is not set).
                                   // This value guarantees that a very
                                   // long and slow GIF does not hang the
                                   // system.
                                   // (1000 = 10000 mS = 10 Seconds)

type
  TGIFVersion = (gvUnknown, gv87a, gv89a);
  TGIFVersionRec = array[0..2] of char;

const
  GIFVersions: array[gv87a..gv89a] of TGIFVersionRec = ('87a', '89a');

type
  // TGIFImage mostly throws exceptions of type GIFException
  GIFException = class(EInvalidGraphic);

  // Severity level as indicated in the Warning methods and the OnWarning event
  TGIFSeverity = (gsInfo, gsWarning, gsError);

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			Delphi 2.x support
  //
  ////////////////////////////////////////////////////////////////////////////////
{$IFDEF VER9x}
  // Delphi 2 doesn't support TBitmap.PixelFormat
{$DEFINE PIXELFORMAT_TOO_SLOW}
type
  // TThreadList from Delphi 3 classes.pas
  TThreadList = class
  private
    FList: TList;
    FLock: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Item: Pointer);
    procedure Clear;
    function LockList: TList;
    procedure Remove(Item: Pointer);
    procedure UnlockList;
  end;

  // From Delphi 3 sysutils.pas
  EOutOfMemory = class(Exception);

  // From Delphi 3 classes.pas
  EOutOfResources = class(EOutOfMemory);

  // From Delphi 3 windows.pas
  PMaxLogPalette = ^TMaxLogPalette;
  TMaxLogPalette = packed record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: array[Byte] of TPaletteEntry;
  end; { TMaxLogPalette }

  // From Delphi 3 graphics.pas. Used by the D3 TGraphic class.
  TProgressStage = (psStarting, psRunning, psEnding);
  TProgressEvent = procedure(Sender: TObject; Stage: TProgressStage;
    PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of
    object;

  // From Delphi 3 windows.pas
  PRGBTriple = ^TRGBTriple;
{$ENDIF}

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			Forward declarations
  //
  ////////////////////////////////////////////////////////////////////////////////
type
  TGIFImage = class;
  TGIFSubImage = class;

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			TGIFItem
  //
  ////////////////////////////////////////////////////////////////////////////////
  TGIFItem = class(TPersistent)
  private
    FGIFImage: TGIFImage;
  protected
    function GetVersion: TGIFVersion; virtual;
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
  public
    constructor Create(GIFImage: TGIFImage); virtual;

    procedure SaveToStream(Stream: TStream); virtual; abstract;
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToFile(const Filename: string); virtual;
    procedure LoadFromFile(const Filename: string); virtual;
    property Version: TGIFVersion read GetVersion;
    property Image: TGIFImage read FGIFImage;
  end;

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			TGIFList
  //
  ////////////////////////////////////////////////////////////////////////////////
  TGIFList = class(TPersistent)
  private
    FItems: TList;
    FImage: TGIFImage;
  protected
    function GetItem(Index: Integer): TGIFItem;
    procedure SetItem(Index: Integer; Item: TGIFItem);
    function GetCount: Integer;
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
  public
    constructor Create(Image: TGIFImage);
    destructor Destroy; override;

    function Add(Item: TGIFItem): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function First: TGIFItem;
    function IndexOf(Item: TGIFItem): Integer;
    procedure Insert(Index: Integer; Item: TGIFItem);
    function Last: TGIFItem;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: TGIFItem): Integer;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromStream(Stream: TStream; Parent: TObject); virtual;
      abstract;

    property Items[Index: Integer]: TGIFItem read GetItem write SetItem;
    default;
    property Count: Integer read GetCount;
    property List: TList read FItems;
    property Image: TGIFImage read FImage;
  end;

  ////////////////////////////////////////////////////////////////////////////////
  //
  //			TGIFColorMap
  //
  ////////////////////////////////////////////////////////////////////////////////
    // One way to do it:
    //  TBaseColor = (bcRed, bcGreen, bcBlue);
    //  TGIFColor = array[bcRed..bcBlue] of BYTE;
    // Another way:
  TGIFColor = packed record
    Red: byte;
    Green: byte;
    Blue: byte;
  end;

  TColorMap = packed array[0..GIFMaxColors - 1] of TGIFColor;
  PColorMap = ^TColorMap;

  TUsageCount = record
    Count: integer; // # of pixels using color index
    Index: integer; // Color index
  end;
  TColormapHistogram = array[0..255] of TUsageCount;
  TColormapReverse = array[0..255] of byte;

  TGIFColorMap = class(TPersistent)
  private
    FColorMap: PColorMap;
    FCount: integer;
    FCapacity: integer;
    FOptimized: boolean;
  protected
    function GetColor(Index: integer): TColor;
    procedure SetColor(Index: integer; Value: TColor);
    function GetBitsPerPixel: integer;
    function DoOptimize: boolean;
    procedure SetCapacity(Size: integer);
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
      abstract;
    procedure BuildHistogram(var Histogram: TColormapHistogram); virtual;
      abstract;
    procedure MapImages(var Map: TColormapReverse); virtual; abstract;

  public
    constructor Create;
    destructor Destroy; override;
    class function Color2RGB(Color: TColor): TGIFColor;
    class function RGB2Color(Color: TGIFColor): TColor;
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream; Count: integer);
    procedure Assign(Source: TPersistent); override;
    function IndexOf(Color: TColor): integer;
    function Add(Color: TColor): integer;
    function AddUnique(Color: TColor): integer;
    procedure Delete(Index: integer);
    procedure Clear;
    function Optimize: boolean; virtual; abstract;
    procedure Changed; virtual; abstract;
    procedure ImportPalette(Palette: HPalette);
    procedure ImportColorTable(Pal: pointer; Count: integer);
    procedure ImportDIBColors(Handle: HDC);
    procedure ImportColorMap(Map: TColorMap; Count: integer);