gifimage.pas

超市系统开发 超市系统开发 超市系统开发 超市系统开发

    );
  TGIFDrawOptions = set of TGIFDrawOption;
  // Note: if goAsync is not set then goDirectDraw should be set. Otherwise
  // the image will not be displayed.

  PGIFPainter = ^TGIFPainter;

  TGIFPainter = class(TThread)
  private
    FImage		: TGIFImage;	// The TGIFImage that owns this painter
    FCanvas		: TCanvas;	// Destination canvas
    FRect		: TRect;	// Destination rect
    FDrawOptions	: TGIFDrawOptions;// Paint options
    FAnimationSpeed	: integer;	// Animation speed %
    FActiveImage	: integer;	// Current frame
    Disposal		,		// Used by synchronized paint
    OldDisposal		: TDisposalMethod;// Used by synchronized paint
    BackupBuffer	: TBitmap;	// Used by synchronized paint
    FrameBuffer		: TBitmap;	// Used by synchronized paint
    Background		: TBitmap;	// Used by synchronized paint
    ValidateDC		: HDC;
    DoRestart		: boolean;	// Flag used to restart animation
    FStarted		: boolean;	// Flag used to signal start of paint
    PainterRef		: PGIFPainter;	// Pointer to var referencing painter
    FEventHandle	: THandle;	// Animation delay event
    ExceptObject	: Exception;	// Eaten exception
    ExceptAddress	: pointer;	// Eaten exceptions address
    FEvent		: TNotifyEvent;	// Used by synchronized events
    FOnStartPaint	: TNotifyEvent;
    FOnPaint		: TNotifyEvent;
    FOnAfterPaint	: TNotifyEvent;
    FOnLoop		: TNotifyEvent;
    FOnEndPaint		: TNotifyEvent;
    procedure DoOnTerminate(Sender: TObject);// Sync. shutdown procedure
    procedure DoSynchronize(Method: TThreadMethod);// Conditional sync stub
{$ifdef SERIALIZE_RENDER}
    procedure PrefetchBitmap;		// Sync. bitmap prefetch
{$endif}
    procedure DoPaintFrame;		// Sync. buffered paint procedure
    procedure DoPaint;			// Sync. paint procedure
    procedure DoEvent;
    procedure SetActiveImage(const Value: integer);// Sync. event procedure
  protected
    procedure Execute; override;
    procedure SetAnimationSpeed(Value: integer);
  public
    constructor Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
      Options: TGIFDrawOptions);
    constructor CreateRef(Painter: PGIFPainter; AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
      Options: TGIFDrawOptions);
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    procedure Restart;
    property Image: TGIFImage read FImage;
    property Canvas: TCanvas read FCanvas;
    property Rect: TRect read FRect write FRect;
    property DrawOptions: TGIFDrawOptions read FDrawOptions write FDrawOptions;
    property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
    property Started: boolean read FStarted;
    property ActiveImage: integer read FActiveImage write SetActiveImage;
    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	;
    property EventHandle: THandle read FEventHandle;
  end;

  TGIFWarning = procedure(Sender: TObject; Severity: TGIFSeverity; Message: string) of object;

  TGIFImage = class(TGraphic)
  private
    IsDrawing		: Boolean;
    IsInsideGetPalette	: boolean;
    FImages		: TGIFImageList;
    FHeader		: TGIFHeader;
    FGlobalPalette	: HPalette;
    FPainters		: TThreadList;
    FDrawOptions	: TGIFDrawOptions;
    FColorReduction	: TColorReduction;
    FReductionBits	: integer;
    FDitherMode		: TDitherMode;
    FCompression	: TGIFCompression;
    FOnWarning		: TGIFWarning;
    FBitmap		: TBitmap;
    FDrawPainter	: TGIFPainter;
    FThreadPriority	: TThreadPriority;
    FAnimationSpeed	: integer;
    FDrawBackgroundColor: TColor;
    FOnStartPaint	: TNotifyEvent;
    FOnPaint		: TNotifyEvent;
    FOnAfterPaint	: TNotifyEvent;
    FOnLoop		: TNotifyEvent;
    FOnEndPaint		: TNotifyEvent;
{$IFDEF VER9x}
    FPaletteModified	: Boolean;
    FOnProgress		: TProgressEvent;
{$ENDIF}
  protected
    // Obsolete: procedure Changed(Sender: TObject); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    function GetHeight: Integer; override;
    procedure SetHeight(Value: Integer); override;
    function GetWidth: Integer; override;
    procedure SetWidth(Value: Integer); override;
    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;
    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 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';