📄 htmlgif1.pas
字号:
{Version 9.4}
{$i HtmlCons.inc}
unit HtmlGif1;
{***************************************************************}
{* htmlgif1.pas *}
{* *}
{* Thanks to Ron Collins for the Gif code in this module. *}
{* His copyright notice is below. *}
{* *}
{* This is only a portion of his code modified slightly *}
{* in a few places to accomodate my own needs. Ron's *}
{* full package may be found at www.Torry.net/gif.htm. *}
{* The zip file is rctgif.zip. *}
{* *}
{***************************************************************}
{ ============================================================================
TGif.pas copyright (C) 2000 R. Collins
rlcollins@ksaits.com
LEGAL STUFF:
This software is provided "as-is". This software comes without warranty
or garantee, explicit or implied. Use this software at your own risk.
The author will not be liable for any damage to equipment, data, or information
that may result while using this software.
By using this software, you agree to the conditions stated above.
This software may be used freely, provided the author's name and copyright
statement remain a part of the source code.
NOTE: CompuServe, Inc. holds the patent to the compression algorithym
used in creating a GIF file. Before you save a GIF file (using LZW
compression) that may be distributed for profit, make sure you understand
the full implications and legal ramifications of using the LZW compression.
============================================================================ }
interface
uses
{$ifdef UseCLX}
SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,
QStdCtrls;
{$else}
Windows, Messages, WinTypes, WinProcs, SysUtils, Classes, Graphics,
Controls, StdCtrls, ExtCtrls, Forms;
{$endif}
// LZW encode table sizes
const
kGifCodeTableSize = 4096;
// the parts of a GIF file
// yes, yes, I know ... I don't have to put in "type"
// before each record definition. I just think it makes it
// easier to read, especially when the definitions may be broken
// across the printed page. if you don't like it, take them out.
type {LDB}
TRGBQUAD = packed record
rgbBlue: Byte;
rgbGreen: Byte;
rgbRed: Byte;
rgbReserved: Byte;
end;
type
PGifDataBlock = ^TGifDataBlock;
TGifDataBlock = record // generic data clump
rSize: integer; // NOTE: array starts at "1"
rData: packed array[1..255] of byte;
end;
type
PGifSignature = ^TgifSignature;
TGifSignature = record // GIF87A or GIF89A
rSignature: packed array[1..6] of char;
end;
type
PGifExtensionGraphic = ^TgifExtensionGraphic;
TGifExtensionGraphic = record // graphic control extension
rBlockSize: integer; // must always be 4
rDisposal: integer; // disposal method when drawing
rUserInputValid: boolean; // wait for user input?
rTransparentValid: boolean; // transparent color given?
rDelayTime: integer; // delay between display images
rTransparentIndex: integer; // into color table
end;
type
PGifExtensionComment = ^TgifExtensionComment;
TGifExtensionComment = record // comment extension
rDataBlockList: TList; // data blocks
end;
type
PGifExtensionText = ^TGifExtensionText;
TGifExtensionText = record // plain text extension
rBlockSize: integer; // must always be 12
rGridLeft: integer; // text grid position
rGridTop: integer;
rGridWidth: integer; // text grid size
rGridHeight: integer;
rCellWidth: integer; // size of a character cell
rCellHeight: integer;
rForegroundIndex: integer; // text foreground color
rBackgroundIndex: integer; // text background color
rDataBlockList: TList; // data blocks
end;
type
PGifExtensionApplication = ^TgifExtensionApplication;
TGifExtensionApplication = record // application extension
rBlockSize: integer; // must always be 11
rIdentifier: packed array[1..8] of char;
rAuthentication: packed array[1..3] of char;
rDataBlockList: TList; // data blocks
end;
type
PGifExtension = ^TGifExtension;
TGifExtension = record // for any extension type
case rLabel: byte of // cannot use CONST names
$f9: (rGraphic: TGifExtensionGraphic);
$fe: (rComment: TGifExtensionComment);
$01: (rText: TGifExtensionText);
$ff: (rApp: TGifExtensionApplication);
$00: (rDummy: longint);
end;
type
PGifScreenDescriptor = ^TGifScreenDescriptor;
TGifScreenDescriptor = record
rWidth: integer; // size of logical screen
rHeight: integer; // size of logical screen
rGlobalColorValid: boolean; // global color table found in file?
rColorResolution: integer; // bits per color
rSorted: boolean; // global colors are sorted?
rGlobalColorSize: integer; // size of global color table
rBackgroundIndex: integer; // background color index
rAspectRatio: integer; // pixel aspect ratio
rGlobalColorTable: integer; // default color table for all images
end;
type
PGifColorTable = ^TGifColorTable; // pointer to a color table
TGifColorTable = record
rSize: integer; // number of valid entries
rColors: array[0..255] of TColor; // the colors
end;
type
PGifImageDescriptor = ^TGifImageDescriptor;
TGifImageDescriptor = record
rIndex: integer; // which image is this?
rLeft: integer; // position of image
rTop: integer; // position of image
rWidth: integer; // size of image
rHeight: integer; // size of image
rLocalColorValid: boolean; // color table used?
rInterlaced: boolean; // interlaced lines?
rSorted: boolean; // color table sorted?
rLocalColorSize: integer; // number entries in local color table
rLocalColorTable: integer; // index into master list
rLZWSize: integer; // LZW minimum code size
rExtensionList: TList; // extensions read before this image
rPixelList: PChar; // decoded pixel indices
rPixelCount: longint; // number of pixels
rBitmap: TBitmap; // the actual image
end;
type
PGifZip = ^TGifZip;
TGifZip = record
rID: PGifImageDescriptor; // image parameters to decode
rCT: PGifColorTable; // color table for this image
rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
rCodeStack: array[0..kGifCodeTableSize-1] of byte; // decode/encoded pixels
rSP: integer; // pointer into CodeStack
rClearCode: integer; // reset decode params
rEndCode: integer; // last code in input stream
rHighCode: integer; // highest LZW code possible
rCurSize: integer; // current code size
rBitString: integer; // steady stream of bits to be decoded
rBits: integer; // number of valid bits in BitString
rCurSlot: integer; // next stack index to store a code
rTopSlot: integer; // highest slot used so far
rMaxVal: boolean; // max code value found?
rCurX: integer; // position of next pixel
rCurY: integer; // position of next pixel
rCurPass: integer; // pixel line pass 1..4
rFirstSlot: integer; // for encoding an image
rNextSlot: integer; // for encoding
rCount: integer; // number of bytes read/written
rLast: integer; // last byte read in
rUnget: boolean; // read a new byte, or use zLast?
end;
{ ---------------------------------------------------------------------------- }
// define a GIF
type
TGif = class(TObject)
private
fIOStream: TMemoryStream; // read or write the image
fDataStream: TMemoryStream; // temp storage for LZW
fExtension: TList; // latest extensions read/written
fSignature: PGifSignature; // version of GIF
fScreenDescriptor: PGifScreenDescriptor; // logical screen descriptor
fImageDescriptorList: TList; // list of all images
fColorTableList: TList; // list of all color tables
fPaletteList: TList; // list of palettes from color tables
fZipData: PGifZip; // for encode/decode image
FLoopCount: integer; // number of animated iterations
// functions that override TGraphic items
protected
function GetHeight: integer;
function GetWidth: integer;
function GetTransparent: boolean;
// procedures to read a bitmap
private
procedure ReadSignature;
procedure ReadScreenDescriptor;
procedure ReadColorTable(Size: integer; var Table: integer);
procedure ReadImageDescriptor;
procedure ReadDataBlockList(List: TList);
procedure ReadExtension(var Done: boolean);
procedure ReadSourceInteger(size: integer; var value: integer);
// LZW encode and decode
procedure LZWDecode(pID: PGifImageDescriptor);
procedure LZWInit(pID: PGifImageDescriptor);
procedure LZWFinit;
procedure LZWReset;
function LZWGetCode: integer;
procedure LZWSaveCode(Code: integer);
procedure LZWDecodeCode(var Code: integer);
procedure LZWSaveSlot(Prefix, Suffix: integer);
procedure LZWIncrPosition;
procedure LZWCheckSlot;
procedure LZWWriteBitmap;
function LZWReadBitmap: integer;
// procedures used to implement the PROPERTIES
function GetSignature: string;
function GetScreenDescriptor: PGifScreenDescriptor;
function GetImageCount: integer;
function GetImageDescriptor(image: integer): PGifImageDescriptor;
function GetBitmap(image: integer): TBitmap;
function GetColorTableCount: integer;
function GetColorTable(table: integer): PGifColorTable;
function GetImageDelay(Image: integer): integer; {LDB}
function GetImageDisposal(Image: integer): integer; {LDB}
function GetColorIndex(image, x, y: integer): integer;
function GetTransparentIndex(image: integer): integer;
function GetTransparentColor: TColor;
function GetImageLeft(image: integer): integer;
function GetImageTop(image: integer): integer;
function GetImageWidth(image: integer): integer;
function GetImageHeight(image: integer): integer;
function GetImageDepth(image: integer): integer;
// generally usefull routines
procedure FreeDataBlockList(var list: TList);
procedure FreeExtensionList(var list: TList);
procedure MakeBitmaps;
function FindGraphicExtension(image: integer): PGifExtensionGraphic;
function FindColorIndex(c: TColor; ct: PGifColorTable): integer;
procedure ExtractLoopCount(List: TList);
public
constructor Create;
destructor Destroy; override;
procedure FreeImage;
procedure LoadFromStream(Source: TStream);
function GetStripBitmap(var Mask: TBitmap): TBitmap; {LDB}
property Signature: string read GetSignature;
property ScreenDescriptor: PGifScreenDescriptor read GetScreenDescriptor;
property ImageCount: integer read GetImageCount;
property ImageDescriptor[Image: integer]: PGifImageDescriptor read GetImageDescriptor;
property Bitmap[Image: integer]: TBitmap read GetBitmap;
property ColorTableCount: integer read GetColorTableCount;
property ColorTable[Table: integer]: PGifColorTable read GetColorTable;
property Height: integer read GetHeight;
property Width: integer read GetWidth ;
property ImageDelay[Image: integer]: integer read GetImageDelay;
property ImageDisposal[Image: integer]: integer read GetImageDisposal;
property Transparent: boolean read GetTransparent;
property TransparentIndex[Image: integer]: integer read GetTransparentIndex;
property TransparentColor: TColor read GetTransparentColor;
property ImageLeft[Image: integer]: integer read GetImageLeft;
property ImageTop[Image: integer]: integer read GetImageTop;
property ImageWidth[Image: integer]: integer read GetImageWidth;
property ImageHeight[Image: integer]: integer read GetImageHeight;
property ImageDepth[Image: integer]: integer read GetImageDepth;
property LoopCount: integer read FLoopCount;
end;
implementation
uses
HtmlUn2;
const
TransColor = $170725;
// GIF record separators
const
kGifImageSeparator: byte = $2c;
kGifExtensionSeparator: byte = $21;
kGifTerminator: byte = $3b;
kGifLabelGraphic: byte = $f9;
kGifLabelComment: byte = $fe;
kGifLabelText: byte = $01;
kGifLabelApplication: byte = $ff;
// define a set of error messages
const
kGifErrorMessages: array[0..27] of string = (
'no error', // 0
'Invalid GIF Signature Code', // 1
'No Local or Global Color Table for Image', // 2
'Unknown Graphics Extension Type', // 3
'Unknown Graphics Operation Code', // 4
'Invalid Extension Block Size', // 5
'[special message]', // 6
'Invalid Extension Block Terminator', // 7
'Invalid Integer Size', // 8
'No GIF Terminator Found', // 9
'Extension Block Out-Of-Order With Image Data', // 10
'Invalid Image Descriptor Index', // 11
'Invalid LZW Code Size', // 12
'Invalid LZW Data Format', // 13
'LZW Code Overflow', // 14
'Value Out Of Range', // 15
'NIL Pointer assigned', // 16
'Invalid Color Table Size', // 17
'No Image Description', // 18
'Invalid Bitmap Image', // 19
'Invalid Color Table Index', // 20
'Invalid Interlace Pass', // 21
'Invalid Bitmap', // 22
'Too Many Colors In Bitmap', // 23
'Unexpected end of file', // 24 {LDB}
'Animated GIF too large', // 25 {LDB}
'Zero width or height', // 26 {LDB}
'next message' //
);
var
GIF_ErrorCode: integer; // last error
GIF_ErrorString: string; // last error
procedure GIF_Error(n: integer); forward;
procedure GIF_ErrorMessage(m: string); forward;
constructor TGif.Create;
begin
inherited Create;
// nothing defined yet
fIOStream := nil;
fDataStream := nil;
fExtension := nil;
fSignature := nil;
fScreenDescriptor := nil;
fImageDescriptorList := nil;
fColorTableList := nil;
fPaletteList := nil;
fZipData := nil;
FLoopCount := -1; // -1 is no loop count entered
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -