gifimage.pas

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

    function GetBounds(Index: integer): WORD;
    procedure SetBounds(Index: integer; Value: WORD);
    function GetCharWidthHeight(Index: integer): BYTE;
    procedure SetCharWidthHeight(Index: integer; Value: BYTE);
    function GetColorIndex(Index: integer): BYTE;
    procedure SetColorIndex(Index: integer; Value: BYTE);
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property Left: WORD index 1 read GetBounds write SetBounds;
    property Top: WORD index 2 read GetBounds write SetBounds;
    property GridWidth: WORD index 3 read GetBounds write SetBounds;
    property GridHeight: WORD index 4 read GetBounds write SetBounds;
    property CharWidth: BYTE index 1 read GetCharWidthHeight write SetCharWidthHeight;
    property CharHeight: BYTE index 2 read GetCharWidthHeight write SetCharWidthHeight;
    property ForegroundColorIndex: BYTE index 1 read GetColorIndex write SetColorIndex;
    property ForegroundColor: TColor read GetForegroundColor;
    property BackgroundColorIndex: BYTE  index 2 read GetColorIndex write SetColorIndex;
    property BackgroundColor: TColor read GetBackgroundColor;
    property Text: TStrings read FText write FText;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFCommentExtension
//
////////////////////////////////////////////////////////////////////////////////
  TGIFCommentExtension = class(TGIFExtension)
  private
    FText		: TStrings;
  protected
    function GetExtensionType: TGIFExtensionType; override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property Text: TStrings read FText;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
  TGIFIdentifierCode = array[0..7] of char;
  TGIFAuthenticationCode = array[0..2] of char;
  TGIFApplicationRec = packed record
    Identifier		: TGIFIdentifierCode;
    Authentication	: TGIFAuthenticationCode;
  end;

  TGIFApplicationExtension = class;
  TGIFAppExtensionClass = class of TGIFApplicationExtension;

  TGIFApplicationExtension = class(TGIFExtension)
  private
    FIdent		: TGIFApplicationRec;
    function GetAuthentication: string;
    function GetIdentifier: string;
  protected
    function GetExtensionType: TGIFExtensionType; override;
    procedure SetAuthentication(const Value: string);
    procedure SetIdentifier(const Value: string);
    procedure SaveData(Stream: TStream); virtual; abstract;
    procedure LoadData(Stream: TStream); virtual; abstract;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    class procedure RegisterExtension(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
    class function FindSubExtension(Stream: TStream): TGIFExtensionClass; override;
    property Identifier: string read GetIdentifier write SetIdentifier;
    property Authentication: string read GetAuthentication write SetAuthentication;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFUnknownAppExtension
//
////////////////////////////////////////////////////////////////////////////////
  TGIFBlock = class(TObject)
  private
    FSize		: BYTE;
    FData		: pointer;
  public
    constructor Create(ASize: integer);
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream);
    property Size: BYTE read FSize;
    property Data: pointer read FData;
  end;

  TGIFUnknownAppExtension = class(TGIFApplicationExtension)
  private
    FBlocks		: TList;
  protected
    procedure SaveData(Stream: TStream); override;
    procedure LoadData(Stream: TStream); override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    property Blocks: TList read FBlocks;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFAppExtNSLoop
//
////////////////////////////////////////////////////////////////////////////////
  TGIFAppExtNSLoop = class(TGIFApplicationExtension)
  private
    FLoops		: WORD;
    FBufferSize		: DWORD;
  protected
    procedure SaveData(Stream: TStream); override;
    procedure LoadData(Stream: TStream); override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    property Loops: WORD read FLoops write FLoops;
    property BufferSize: DWORD read FBufferSize write FBufferSize;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
  TGIFImageList = class(TGIFList)
  protected
    function GetImage(Index: Integer): TGIFSubImage;
    procedure SetImage(Index: Integer; SubImage: TGIFSubImage);
  public
    procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
    procedure SaveToStream(Stream: TStream); override;
    property SubImages[Index: Integer]: TGIFSubImage read GetImage write SetImage; default;
  end;

  // Compression algorithms
  TGIFCompression =
    (gcLZW,			// Normal LZW compression
     gcRLE			// GIF compatible RLE compression
    );

  // Color reduction methods
  TColorReduction =
    (rmNone,			// Do not perform color reduction
     rmWindows20,		// Reduce to the Windows 20 color system palette
     rmWindows256,		// Reduce to the Windows 256 color halftone palette (Only works in 256 color display mode)
     rmWindowsGray,		// Reduce to the Windows 4 grayscale colors
     rmMonochrome,		// Reduce to a black/white monochrome palette
     rmGrayScale,		// Reduce to a uniform 256 shade grayscale palette
     rmNetscape,		// Reduce to the Netscape 216 color palette
     rmQuantize,		// Reduce to optimal 2^n color palette
     rmQuantizeWindows,		// Reduce to optimal 256 color windows palette
     rmPalette			// Reduce to custom palette
    );
  TDitherMode =
    (dmNearest,			// Nearest color matching w/o error correction
     dmFloydSteinberg,		// Floyd Steinberg Error Diffusion dithering
     dmStucki,			// Stucki Error Diffusion dithering
     dmSierra,			// Sierra Error Diffusion dithering
     dmJaJuNI,			// Jarvis, Judice & Ninke Error Diffusion dithering
     dmSteveArche,		// Stevenson & Arche Error Diffusion dithering
     dmBurkes			// Burkes Error Diffusion dithering
     // dmOrdered,		// Ordered dither
    );

  // Optimization options
  TGIFOptimizeOption =
    (ooCrop,			// Crop animated GIF frames
     ooMerge,			// Merge pixels of same color
     ooCleanup,			// Remove comments and application extensions
     ooColorMap,		// Sort color map by usage and remove unused entries
     ooReduceColors		// Reduce color depth ***NOT IMPLEMENTED***
    );
  TGIFOptimizeOptions = set of TGIFOptimizeOption;

  TGIFDrawOption =
    (goAsync,			// Asyncronous draws (paint in thread)
     goTransparent,		// Transparent draws
     goAnimate,			// Animate draws
     goLoop,			// Loop animations
     goLoopContinously,		// Ignore loop count and loop forever
     goValidateCanvas,		// Validate canvas in threaded paint ***NOT IMPLEMENTED***
     goDirectDraw,		// Draw() directly on canvas
     goClearOnLoop,		// Clear animation on loop
     goTile,			// Tiled display
     goDither,			// Dither to Netscape palette
     goAutoDither		// Only dither on 256 color systems
    );
  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;
    FForceFrame: Integer;  // 2004.03.09
    FDrawBackgroundColor: TColor;
    FOnStartPaint	: TNotifyEvent;
    FOnPaint		: TNotifyEvent;
    FOnAfterPaint	: TNotifyEvent;
    FOnLoop		: TNotifyEvent;
    FOnEndPaint		: TNotifyEvent;
{$IFDEF VER9x}
    FPaletteModified	: Boolean;
    FOnProgress		: TProgressEvent;
{$ENDIF}
    function GetAnimate: Boolean;  // 2002.07.07
    procedure SetAnimate(const Value: Boolean);  // 2002.07.07
    procedure SetForceFrame(const Value: Integer);  // 2004.03.09
  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;