gifimage.pas

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

  //
  ////////////////////////////////////////////////////////////////////////////////
  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;
    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;