?? gifimage.pas
字號:
//: 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}
{$define DEBUG_PERFORMANCE}
{$else}
{$ifdef DEBUG_DITHERPERFORMANCE}
{$define DEBUG_PERFORMANCE}
{$else}
{$ifdef DEBUG_DRAWPERFORMANCE}
{$define DEBUG_PERFORMANCE}
{$else}
{$ifdef DEBUG_RENDERPERFORMANCE}
{$define DEBUG_PERFORMANCE}
{$endif}
{$endif}
{$endif}
{$endif}
{$endif}
{$endif}
{$endif}
uses
{$ifdef DEBUG}
dialogs,
{$endif}
mmsystem, // timeGetTime()
messages,
Consts;
////////////////////////////////////////////////////////////////////////////////
//
// Misc consts
//
////////////////////////////////////////////////////////////////////////////////
const
{ Extension/block label values }
bsPlainTextExtension = $01;
bsGraphicControlExtension = $F9;
bsCommentExtension = $FE;
bsApplicationExtension = $FF;
bsImageDescriptor = Ord(',');
bsExtensionIntroducer = Ord('!');
bsTrailer = ord(';');
// Thread messages - Used by TThread.Synchronize()
CM_DESTROYWINDOW = $8FFE; // Defined in classes.pas
CM_EXECPROC = $8FFF; // Defined in classes.pas
////////////////////////////////////////////////////////////////////////////////
//
// Design Time support
//
////////////////////////////////////////////////////////////////////////////////
//: Dummy component registration to add design-time support of GIFs to TImage.
// Since TGIFImage isn't a component there's nothing to register here, but
// since Register is only called at design time we can set the design time
// GIF paint options here (modify as you please):
procedure Register;
begin
// Don't loop animations at design-time. Animated GIFs will animate once and
// then stop thus not using CPU resources and distracting the developer.
Exclude(GIFImageDefaultDrawOptions, goLoop);
end;
////////////////////////////////////////////////////////////////////////////////
//
// Utilities
//
////////////////////////////////////////////////////////////////////////////////
//: Creates a 216 color uniform non-dithering Netscape palette.
function WebPalette: HPalette;
type
TLogWebPalette = packed record
palVersion : word;
palNumEntries : word;
PalEntries : array[0..5,0..5,0..5] of TPaletteEntry;
end;
var
r, g, b : byte;
LogWebPalette : TLogWebPalette;
LogPalette : TLogpalette absolute LogWebPalette; // Stupid typecast
begin
with LogWebPalette do
begin
palVersion:= $0300;
palNumEntries:= 216;
for r:=0 to 5 do
for g:=0 to 5 do
for b:=0 to 5 do
begin
with PalEntries[r,g,b] do
begin
peRed := 51 * r;
peGreen := 51 * g;
peBlue := 51 * b;
peFlags := 0;
end;
end;
end;
Result := CreatePalette(Logpalette);
end;
(*
** GDI Error handling
** Adapted from graphics.pas
*)
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
{$ifdef D3_BCB3}
function GDICheck(Value: Integer): Integer;
{$else}
function GDICheck(Value: Cardinal): Cardinal;
{$endif}
var
ErrorCode : integer;
Buf : array [byte] of char;
function ReturnAddr: Pointer;
// From classes.pas
asm
MOV EAX,[EBP+4] // sysutils.pas says [EBP-4], but this works !
end;
begin
if (Value = 0) then
begin
ErrorCode := GetLastError;
if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
raise EOutOfResources.Create(Buf) at ReturnAddr
else
raise EOutOfResources.Create(SOutOfResources) at ReturnAddr;
end;
Result := Value;
end;
{$IFDEF R_PLUS}
{$RANGECHECKS ON}
{$UNDEF R_PLUS}
{$ENDIF}
(*
** Raise error condition
*)
procedure Error(msg: string);
function ReturnAddr: Pointer;
// From classes.pas
asm
MOV EAX,[EBP+4] // sysutils.pas says [EBP-4] !
end;
begin
raise GIFException.Create(msg) at ReturnAddr;
end;
(*
** Return number bytes required to
** hold a given number of bits.
*)
function ByteAlignBit(Bits: Cardinal): Cardinal;
begin
Result := (Bits+7) SHR 3;
end;
// Rounded up to nearest 2
function WordAlignBit(Bits: Cardinal): Cardinal;
begin
Result := ((Bits+15) SHR 4) SHL 1;
end;
// Rounded up to nearest 4
function DWordAlignBit(Bits: Cardinal): Cardinal;
begin
Result := ((Bits+31) SHR 5) SHL 2;
end;
// Round to arbitrary number of bits
function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
begin
Dec(Alignment);
Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
Res
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -