gifimage.pas

基于DELPHI的图片浏览系统设计与实现

    procedure AssignTo(Dest: TPersistent); override;
    function InternalPaint(Painter: PGIFPainter; ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function Equals(Graphic: TGraphic): Boolean; override;
    function GetPalette: HPALETTE; {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    procedure SetPalette(Value: HPalette); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    function GetEmpty: Boolean; override;
    procedure WriteData(Stream: TStream); override;
    function GetIsTransparent: Boolean;
    function GetVersion: TGIFVersion;
    function GetColorResolution: integer;
    function GetBitsPerPixel: integer;
    function GetBackgroundColorIndex: BYTE;
    procedure SetBackgroundColorIndex(const Value: BYTE);
    function GetBackgroundColor: TColor;
    procedure SetBackgroundColor(const Value: TColor);
    function GetAspectRatio: BYTE;
    procedure SetAspectRatio(const Value: BYTE);
    procedure SetDrawOptions(Value: TGIFDrawOptions);
    procedure SetAnimationSpeed(Value: integer);
    procedure SetReductionBits(Value: integer);
    procedure NewImage;
    function GetBitmap: TBitmap;
    function NewBitmap: TBitmap;
    procedure FreeBitmap;
    function GetColorMap: TGIFColorMap;
    function GetDoDither: boolean;
    property DrawPainter: TGIFPainter read FDrawPainter; // Extremely volatile
    property DoDither: boolean read GetDoDither;
{$IFDEF VER9x}
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
{$ENDIF}
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String);  // 2002.07.07
    function Add(Source: TPersistent): integer;
    procedure Pack;
    procedure OptimizeColorMap;
    procedure Optimize(Options: TGIFOptimizeOptions;
      ColorReduction: TColorReduction; DitherMode: TDitherMode;
      ReductionBits: integer);
    procedure Clear;
    procedure StopDraw;
    function Paint(ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
    procedure PaintStart;
    procedure PaintPause;
    procedure PaintStop;
    procedure PaintResume;
    procedure PaintRestart;
    procedure Warning(Sender: TObject; Severity: TGIFSeverity; Message: string); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    property GlobalColorMap: TGIFColorMap read GetColorMap;
    property Version: TGIFVersion read GetVersion;
    property Images: TGIFImageList read FImages;
    property ColorResolution: integer read GetColorResolution;
    property BitsPerPixel: integer read GetBitsPerPixel;
    property BackgroundColorIndex: BYTE read GetBackgroundColorIndex write SetBackgroundColorIndex;
    property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
    property AspectRatio: BYTE read GetAspectRatio write SetAspectRatio;
    property Header: TGIFHeader read FHeader; // ***OBSOLETE***
    property IsTransparent: boolean read GetIsTransparent;
    property DrawOptions: TGIFDrawOptions read FDrawOptions write SetDrawOptions;
    property DrawBackgroundColor: TColor read FDrawBackgroundColor write FDrawBackgroundColor;
    property ColorReduction: TColorReduction read FColorReduction write FColorReduction;
    property ReductionBits: integer read FReductionBits write SetReductionBits;
    property DitherMode: TDitherMode read FDitherMode write FDitherMode;
    property Compression: TGIFCompression read FCompression write FCompression;
    property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
    property Animate: Boolean read GetAnimate write SetAnimate;  // 2002.07.07
    property ForceFrame: Integer read FForceFrame write SetForceFrame;  // 2004.03.09
    property Painters: TThreadList read FPainters;
    property ThreadPriority: TThreadPriority read FThreadPriority write FThreadPriority;
    property Bitmap: TBitmap read GetBitmap; // Volatile - beware!
    property OnWarning: TGIFWarning read FOnWarning write FOnWarning;
    property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
    property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
    property OnEndPaint	: TNotifyEvent read FOnEndPaint	 write FOnEndPaint	;
{$IFDEF VER9x}
    property Palette: HPALETTE read GetPalette write SetPalette;
    property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
{$ENDIF}
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      Utility routines
//
////////////////////////////////////////////////////////////////////////////////
  // WebPalette creates a 216 color uniform palette a.k.a. the Netscape Palette
  function WebPalette: HPalette;

  // ReduceColors
  // Map colors in a bitmap to their nearest representation in a palette using
  // the methods specified by the ColorReduction and DitherMode parameters.
  // The ReductionBits parameter specifies the desired number of colors (bits
  // per pixel) when the reduction method is rmQuantize. The CustomPalette
  // specifies the palette when the rmPalette reduction method is used.
  function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
    DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;

  // CreateOptimizedPaletteFromManyBitmaps
  //: Performs Color Quantization on multiple bitmaps.
  // The Bitmaps parameter is a list of bitmaps. Returns an optimized palette.
  function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
    Windows: boolean): hPalette;

{$IFDEF VER9x}
  // From Delphi 3 graphics.pas
type
  TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
{$ENDIF}

  procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
    var ImageSize: longInt; PixelFormat: TPixelFormat);
  function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
   var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;

////////////////////////////////////////////////////////////////////////////////
//
//                      Global variables
//
////////////////////////////////////////////////////////////////////////////////
// GIF Clipboard format identifier for use by LoadFromClipboardFormat and
// SaveToClipboardFormat.
// Set in Initialization section.
var
  CF_GIF: WORD;

////////////////////////////////////////////////////////////////////////////////
//
//                      Library defaults
//
////////////////////////////////////////////////////////////////////////////////
var
  //: Default options for TGIFImage.DrawOptions.
  GIFImageDefaultDrawOptions : TGIFDrawOptions =
    [goAsync, goLoop, goTransparent, goAnimate, goDither, goAutoDither
{$IFDEF STRICT_MOZILLA}
     ,goClearOnLoop
{$ENDIF}
    ];

  // WARNING! Do not use goAsync and goDirectDraw unless you have absolute
  // control of the destination canvas.
  // TGIFPainter will continue to write on the canvas even after the canvas has
  // been deleted, unless *you* prevent it.
  // The goValidateCanvas option will fix this problem if it is ever implemented.

  //: Default color reduction methods for bitmap import.
  // These are the fastest settings, but also the ones that gives the
  // worst result (in most cases).
  GIFImageDefaultColorReduction: TColorReduction = rmNetscape;
  GIFImageDefaultColorReductionBits: integer = 8; // Range 3 - 8
  GIFImageDefaultDitherMode: TDitherMode = dmNearest;

  //: Default encoder compression method.
  GIFImageDefaultCompression: TGIFCompression = gcLZW;

  //: Default painter thread priority
  GIFImageDefaultThreadPriority: TThreadPriority = tpNormal;

  //: Default animation speed in % of normal speed (range 0 - 1000)
  GIFImageDefaultAnimationSpeed: integer = 100;

  // DoAutoDither is set to True in the initializaion section if the desktop DC
  // supports 256 colors or less.
  // It can be modified in your application to disable/enable Auto Dithering
  DoAutoDither: boolean = False;

  // Palette is set to True in the initialization section if the desktop DC
  // supports 256 colors or less.
  // You should NOT modify it.
  PaletteDevice: boolean = False;

  // Set GIFImageRenderOnLoad to True to render (convert to bitmap) the
  // GIF frames as they are loaded instead of rendering them on-demand.
  // This might increase resource consumption and will increase load time,
  // but will cause animated GIFs to display more smoothly.
  GIFImageRenderOnLoad: boolean = False;

  // If GIFImageOptimizeOnStream is true, the GIF will be optimized
  // before it is streamed to the DFM file.
  // This will not affect TGIFImage.SaveToStream or SaveToFile.
  GIFImageOptimizeOnStream: boolean = False;

////////////////////////////////////////////////////////////////////////////////
//
//                      Design Time support
//
////////////////////////////////////////////////////////////////////////////////
// Dummy component registration for design time support of GIFs in TImage
procedure Register;

////////////////////////////////////////////////////////////////////////////////
//
//                      Error messages
//
////////////////////////////////////////////////////////////////////////////////
{$ifndef VER9x}
resourcestring
{$else}
const
{$endif}
  // GIF Error messages
  sOutOfData		= 'Premature end of data';
  sTooManyColors	= 'Color table overflow';
  sBadColorIndex	= 'Invalid color index';
  sBadVersion		= 'Unsupported GIF version';
  sBadSignature		= 'Invalid GIF signature';
  sScreenBadColorSize	= 'Invalid number of colors specified in Screen Descriptor';
  sImageBadColorSize	= 'Invalid number of colors specified in Image Descriptor';
  sUnknownExtension	= 'Unknown extension type';
  sBadExtensionLabel	= 'Invalid extension introducer';
  sOutOfMemDIB		= 'Failed to allocate memory for GIF DIB';
  sDIBCreate		= 'Failed to create DIB from Bitmap';
  sDecodeTooFewBits	= 'Decoder bit buffer under-run';
  sDecodeCircular	= 'Circular decoder table entry';
  sBadTrailer		= 'Invalid Image trailer';
  sBadExtensionInstance	= 'Internal error: Extension Instance does not match Extension Label';
  sBadBlockSize		= 'Unsupported Application Extension block size';
  sBadBlock		= 'Unknown GIF block type';
  sUnsupportedClass	= 'Object type not supported for operation';
  sInvalidData		= 'Invalid GIF data';
  sBadHeight		= 'Image height too small for contained frames';
  sBadWidth		= 'Image width too small for contained frames';
{$IFNDEF REGISTER_TGIFIMAGE}
  sGIFToClipboard	= 'Clipboard operations not supported for GIF objects';
{$ELSE}
  sFailedPaste		= 'Failed to store GIF on clipboard';
{$IFDEF VER9x}
  sUnknownClipboardFormat= 'Unsupported clipboard format';
{$ENDIF}
{$ENDIF}
  sScreenSizeExceeded	= 'Image exceeds Logical Screen size';
  sNoColorTable		= 'No global or local color table defined';
  sBadPixelCoordinates	= 'Invalid pixel coordinates';
  sUnsupportedBitmap	= 'Unsupported bitmap format';
  sInvalidPixelFormat	= 'Unsupported PixelFormat';
  sBadDimension		= 'Invalid image dimensions';
  sNoDIB		= 'Image has no DIB';
  sInvalidStream	= 'Invalid stream operation';
  sInvalidColor		= 'Color not in color table';
  sInvalidBitSize	= 'Invalid Bits Per Pixel value';
  sEmptyColorMap	= 'Color table is empty';
  sEmptyImage		= 'Image is empty';
  sInvalidBitmapList	= 'Invalid bitmap list';
  sInvalidReduction	= 'Invalid reduction method';
{$IFDEF VER9x}
  // From Delphi 3 consts.pas
  SOutOfResources	= 'Out of system resources';
  SInvalidBitmap	= 'Bitmap image is not valid';
  SScanLine		= 'Scan line index out of range';
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//                      Misc texts
//
////////////////////////////////////////////////////////////////////////////////
  // File filter name
  sGIFImageFile		= 'GIF Image';

  // Progress messages
  sProgressLoading	= 'Loading...';
  sProgressSaving	= 'Saving...';
  sProgressConverting	= 'Converting...';
  sProgressRendering	= 'Rendering...';
  sProgressCopying	= 'Copying...';
  sProgressOptimizing	= 'Optimizing...';


////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
//			Implementation
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation

{ This makes me long for the C preprocessor... }
{$ifdef DEBUG}
  {$ifdef DEBUG_COMPRESSPERFORMANCE}
    {$define DEBUG_PERFORMANCE}
  {$else}
    {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
      {$define DEBUG_PERFORMANCE}
    {$else}
      {$ifdef DEBUG_DITHERPERFORMANCE}
        {$def