FastDIB，谁有这个控件发给我一个，谢谢(100分)

[]support@lansnail.com，谢谢

unit FastDIB; // TFastDIB v3.89i - 1999~2001 G-Soft
// Updated: 5/01/2001
interface // http://gfody.com <gfody@home.com>

{$R-}

uses Windows;

type

PFColor =^TFColor;
TFColor = packed record
b,g,r: Byte;
end;

PFColorA =^TFColorA;
TFColorA = packed record
case Integer of
0: (i: DWord);
1: (c: TFColor);
2: (hi,lo: Word);
3: (b,g,r,a: Byte);
end;

PFColorTable =^TFColorTable;
TFColorTable = array[Byte]of TFColorA;

PFPackedColorTable =^TFPackedColorTable;
TFPackedColorTable = array[Byte]of TFColor;

TLines = array[Word]of Pointer; PLines =^TLines;
TLine8 = array[Word]of Byte; PLine8 =^TLine8;
TLine16 = array[Word]of Word; PLine16 =^TLine16;
TLine24 = array[Word]of TFColor; PLine24 =^TLine24;
TLine32 = array[Word]of TFColorA; PLine32 =^TLine32;
TPixels8 = array[Word]of PLine8; PPixels8 =^TPixels8;
TPixels16 = array[Word]of PLine16; PPixels16 =^TPixels16;
TPixels24 = array[Word]of PLine24; PPixels24 =^TPixels24;
TPixels32 = array[Word]of PLine32; PPixels32 =^TPixels32;

PBMInfoHeader =^TBMInfoHeader;
TBMInfoHeader = packed record
Size: DWord;
Width: Integer;
Height: Integer;
Planes: Word;
BitCount: Word;
Compression: DWord;
SizeImage: DWord;
XPelsPerMeter: Integer;
YPelsPerMeter: Integer;
ClrUsed: DWord;
ClrImportant: DWord;
end;

PBMInfo =^TBMInfo;
TBMInfo = packed record
Header: TBMInfoHeader;
case Integer of
0: (Colors: TFColorTable);
1: (RMask,GMask,BMask: DWord);
end;

TFastDIB = class
hDC: HDC; // handle to memory device context (when UseGDI=True)
hBrush: HBRUSH; // current brush in hDC
hPen: HPEN; // current pen in hDC
hFont: HFONT; // current font in hDC
Handle: HBITMAP; // current DIB in hDC

BWidth: Integer; // number of bytes per scanline
AbsHeight: Integer; // number of scanlines in bitmap
Gap: Integer; // number of pad bytes at end of scanline
Bits: PLine8; // typed pointer to bits
Colors: PFColorTable; // typed pointer to color table
Info: TBMInfo; // bitmap information

Bpb,Bpg,Bpr: Byte; // bits per channel (only 16 & 32bpp)
BShr,GShr,RShr: Byte; // (B shr BShr)or(G shr GShr shl GShl)or
BShl,GShl,RShl: Byte; // (R shr RShr shl RShl) = 16bit/32bit pixel

Scanlines: PLines; // typed pointer to array of scanline offsets
Pixels8: PPixels8; // typed scanlines - Pixels8[y,x]: Byte
Pixels16: PPixels16; // typed scanlines - Pixels16[y,x]: Word
Pixels24: PPixels24; // typed scanlines - Pixels24[y,x]: TFColor
Pixels32: PPixels32; // typed scanlines - Pixels32[y,x]: TFColorA

UseGDI: Boolean; // default true, allocate GDI handle & surface
FreeDC: Boolean; // default true, free GDI surface on destroy
FreeBits: Boolean; // default true, free Bits on destroy (non GDI only)
FreeHandle: Boolean; // default true, free GDI handle on destroy

constructor Create;
destructor Destroy; override;
procedure PreDestroy;
procedure Assign(Bmp:TFastDIB);

// use these for debugging or reference (these don't belong in long loops)
procedure SetPixel(y,x:Integer;c:TFColor);
procedure SetPixelB(y,x:Integer;c:Byte);
function GetPixel(y,x:Integer):TFColor;
function GetPixelB(y,x:Integer):Byte;
property Pixels[y,x:Integer]:TFColor read GetPixel write SetPixel;
property PixelsB[y,x:Integer]:Byte read GetPixelB write SetPixelB;

// convenience (BCB doesn't like this)
property Width: Integer read Info.Header.Width write Info.Header.Width;
property Height: Integer read Info.Header.Height write Info.Header.Height;
property Bpp: Word read Info.Header.BitCount write Info.Header.BitCount;
property Compression: DWord read Info.Header.Compression write Info.Header.Compression;
property Size: DWord read Info.Header.SizeImage write Info.Header.SizeImage;
property ClrUsed: DWord read Info.Header.ClrUsed write Info.Header.ClrUsed;
property RMask: DWord read Info.RMask write Info.RMask;
property GMask: DWord read Info.GMask write Info.GMask;
property BMask: DWord read Info.BMask write Info.BMask;

// initializers
procedure SetSize(fWidth,fHeight:Integer;fBpp:Byte);
procedure SetSizeEx(fWidth,fHeight:Integer;fBpp,fBpr,fBpg,fBpb:Byte);
procedure SetSizeIndirect(bmInfo:TBMInfo);
procedure SetInterface(fBitsointer;fWidth,fHeight:Integer;fBpp,fBpr,fBpg,fBpb:Byte);
procedure SetInterfaceIndirect(fBitsointer;bmInfo:TBMInfo);
procedure SetSubset(Bmp:TFastDIB;x,y,w,h:Integer);
procedure MakeCopy(Bmp:TFastDIB;CopyBits:Boolean);
procedure LoadFromHandle(hBmp:HBITMAP);
procedure LoadFromFile(FileName:string);
procedure LoadFromRes(hInst:HINST;ResID,ResTypeChar);
procedure LoadFromClipboard;

// blitting methods
procedure UpdateColors;
procedure Draw(fDC:HDC;x,y:Integer);
procedure Stretch(fDC:HDC;x,y,w,h:Integer);
procedure DrawRect(fDC:HDC;x,y,w,h,sx,sy:Integer);
procedure StretchRect(fDC:HDC;x,y,w,h,sx,sy,sw,sh:Integer);
procedure PlgDraw(fDC:HDC;x1,y1,x2,y2,x3,y3:Integer);
procedure MaskDraw(fDC:HDC;x,y:Integer;Mono:TFastDIB);
procedure MaskRect(fDC:HDC;x,y,w,h,sx,sy,mx,my:Integer;Mono:TFastDIB);
procedure TransDraw(fDC:HDC;x,y:Integer;c:TFColor);
procedure TransStretch(fDC:HDC;x,y,w,h:Integer;c:TFColor);
procedure AlphaDraw(fDC:HDC;x,y:Integer;a:Byte;hasAlpha:Boolean);
procedure AlphaStretch(fDC:HDC;x,y,w,h:Integer;a:Byte;hasAlpha:Boolean);
procedure TileDraw(fDC:HDC;x,y,w,h:Integer);

// drawing tools (UseGDI=True)
procedure SetPen(Style,Width,ColorWord);
procedure SetBrush(Style,Hatch,ColorWord);
procedure SetFont(Font:string;Size:Integer);
procedure SetFontEx(Font:string;Width,Height,Weight:Integer;Italic,Underline,Strike:Boolean);
procedure SetTextColor(ColorWord);
procedure SetTransparent(Transparent:Boolean);
procedure SetBkColor(ColorWord);
procedure Ellipse(x1,y1,x2,y2:Integer);
procedure FillRect(Rect:TRect);
procedure LineTo(x,y:Integer);
procedure MoveTo(x,y:Integer);
procedure Polygon(Points:array of TPoint);
procedure Polyline(Points:array of TPoint);
procedure Rectangle(x1,y1,x2,y2:Integer);
procedure TextOut(x,y:Integer;Text:string);
procedure DrawText(Text:string;Rect:TRect;Flags:Integer);

// utilities
procedure Clear(c:TFColor);
procedure ClearB(cWord);
procedure SaveToClipboard;
procedure SaveToFile(FileName:string);
procedure CopyRect(Src:TFastDIB;x,y,w,h,sx,sy:Integer);
procedure FillColors(i1,i2:Integer;Keys:array of TFColor);
procedure ShiftColors(i1,i2,Amount:Integer);
end;

TCPUFeature = (cfCX8,cfCMOV,cfMMX,cfMMX2,cfSSE,cfSSE2,cf3DNow,cf3DNow2);
TCPUFeatureSet = set of TCPUFeature;

TCPUInfo = record
VendorID: string[12];
Features: TCPUFeatureSet;
CPUCount,Family,Model: Byte;
end;

TBlendFunction = record
BlendOp,BlendFlags,Alpha,Format: Byte;
end;

var
CPUInfo: TCPUInfo;

TransBlit: function(p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11Word)Word; stdcall;
AlphaBlit: function(p1,p2,p3,p4,p5,p6,p7,p8,p9,p10Word;p11:TBlendFunction)Word; stdcall;

function CreateDIB(fDC:HDC;bmInfoBMInfo;iColorWord;var BitsLine8;hSection,dwOffsetWord):HBITMAP; stdcall;
function MaskBlit(p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12Word)Word; stdcall;

// extra goodies(8.3k)!
procedure SetAlphaChannel(Bmp,Alpha:TFastDIB);
procedure MultiplyAlpha(Bmp:TFastDIB);
procedure SwapChannels(Bmp:TFastDIB);
procedure FillMem(Memointer;Size,Value:Integer);
procedure Clear(Bmp:TFastDIB;c:TFColor);
procedure ClearB(Bmp:TFastDIB;cWord);
procedure DecodeRLE4(Bmp:TFastDIB;Dataointer);
procedure DecodeRLE8(Bmp:TFastDIB;Dataointer);
procedure FillColors(PalFColorTable;i1,i2,nKeys:Integer;KeysLine24);
function ClosestColor(PalFColorTable;Max:Integer;c:TFColor):Byte;
function LoadHeader(Dataointer;var bmInfo:TBMInfo):Integer;
function PackedDIB(Bmp:TFastDIB)ointer;
function CountColors(Bmp:TFastDIB)Word;

procedure IntToMask(Bpr,Bpg,BpbWord;var RMsk,GMsk,BMskWord);
procedure MaskToInt(RMsk,GMsk,BMskWord;var Bpr,Bpg,BpbWord);
function UnpackColorTable(Table:TFPackedColorTable):TFColorTable;
function PackColorTable(Table:TFColorTable):TFPackedColorTable;
function FRGB(r,g,b:Byte):TFColor;
function FRGBA(r,g,b,a:Byte):TFColorA;
function ColorToInt(c:TFColor)Word;
function ColorToIntA(c:TFColorA)Word;
function IntToColor(iWord):TFColor;
function IntToColorA(iWord):TFColorA;
function Scale8(i,n:Integer):Integer;
function Get16Bpg:Byte;

const
tfBlack: TFColor=(b:$00;g:$00;r:$00);
tfMaroon: TFColor=(b:$00;g:$00;r:$80);
tfGreen: TFColor=(b:$00;g:$80;r:$00);
tfOlive: TFColor=(b:$00;g:$80;r:$80);
tfNavy: TFColor=(b:$80;g:$00;r:$00);
tfPurple: TFColor=(b:$80;g:$00;r:$80);
tfTeal: TFColor=(b:$80;g:$80;r:$00);
tfGray: TFColor=(b:$80;g:$80;r:$80);
tfSilver: TFColor=(b:$C0;g:$C0;r:$C0);
tfRed: TFColor=(b:$00;g:$00;r:$FF);
tfLime: TFColor=(b:$00;g:$FF;r:$00);
tfYellow: TFColor=(b:$00;g:$FF;r:$FF);
tfBlue: TFColor=(b:$FF;g:$00;r:$00);
tfFuchsia: TFColor=(b:$FF;g:$00;r:$FF);
tfAqua: TFColor=(b:$FF;g:$FF;r:$00);
tfLtGray: TFColor=(b:$C0;g:$C0;r:$C0);
tfDkGray: TFColor=(b:$80;g:$80;r:$80);
tfWhite: TFColor=(b:$FF;g:$FF;r:$FF);

implementation

function CreateDIB; external 'gdi32.dll' name 'CreateDIBSection';
function MaskBlit; external 'gdi32.dll' name 'MaskBlt';

constructor TFastDIB.Create;
begin
inherited Create;
UseGDI:=True;
Bits:=nil;
Scanlines:=nil;
FillChar(Info,SizeOf(Info),0);
Info.Header.Size:=SizeOf(TBMInfoHeader);
Info.Header.Planes:=1;
Colors:=@Info.Colors;
end;

destructor TFastDIB.Destroy;
begin
PreDestroy;
inherited Destroy;
end;

procedure TFastDIB.PreDestroy;
begin
if(hDC<>0)and FreeDC then DeleteDC(hDC);
if(Handle<>0)and FreeHandle then DeleteObject(Handle);
if(hPen<>0)then DeleteObject(hPen);
if(hFont<>0)then DeleteObject(hFont);
if(hBrush<>0)then DeleteObject(hBrush);
if(Scanlines<>nil)then ReallocMem(Scanlines,0);
if(Bits<>nil)and FreeBits then ReallocMem(Bits,0);
end;

procedure TFastDIB.Assign(Bmp:TFastDIB);
begin
PreDestroy;

hDC:=Bmp.hDC; hBrush:=Bmp.hBrush;
hPen:=Bmp.hPen; hFont:=Bmp.hFont;
Handle:=Bmp.Handle; BWidth:=Bmp.BWidth;
AbsHeight:=Bmp.AbsHeight; Gap:=Bmp.Gap;
Bits:=Bmp.Bits; Colors^:=Bmp.Colors^;
Info:=Bmp.Info; BShr:=Bmp.BShr;
GShr:=Bmp.GShr; GShl:=Bmp.GShl;
RShr:=Bmp.RShr; RShl:=Bmp.RShl;
Bpr:=Bmp.Bpr; Bpg:=Bmp.Bpg;
Bpb:=Bmp.Bpb; Scanlines:=Bmp.Scanlines;
Pixels8:=Bmp.Pixels8; Pixels16:=Bmp.Pixels16;
Pixels24:=Bmp.Pixels24; Pixels32:=Bmp.Pixels32;
UseGDI:=Bmp.UseGDI; FreeDC:=Bmp.FreeDC;
FreeBits:=Bmp.FreeBits; FreeHandle:=Bmp.FreeHandle;

Bmp.FreeDC:=False;
Bmp.FreeHandle:=False;
Bmp.hPen:=0;
Bmp.hFont:=0;
Bmp.hBrush:=0;
Bmp.Scanlines:=nil;
Bmp.FreeBits:=False;
Bmp.Free;
end;

procedure TFastDIB.SetPixel(y,x:Integer;c:TFColor);
begin
case Bpp of
1,4,8: PixelsB[y,x]:=ClosestColor(Colors,(1 shl Bpp)-1,c);
16: Pixels16[y,x]:=
c.r shr RShr shl RShl or
c.g shr GShr shl GShl or
c.b shr BShr;
24: Pixels24[y,x]:=c;
32: if Compression=0 then Pixels32[y,x].c:=c else
Pixels32[y,x].i:=
c.r shr RShr shl RShl or
c.g shr GShr shl GShl or
c.b shr BShr;
end;
end;

procedure TFastDIB.SetPixelB(y,x:Integer;c:Byte);
var
mo: Byte;
pb: PByte;
begin
case Bpp of
1:
begin
c:=c and 1;
mo:=(x and 7)xor 7;
pb:=@Pixels8[y,x shr 3];
pb^:=pb^ and(not(1 shl mo))or(c shl mo);
end;
4:
begin
c:=c and 15;
pb:=@Pixels8[y,x shr 1];
if(x and 1)=0 then pb^:=(pb^and $0F)or(c shl 4)else pb^:=(pb^and $F0)or c;
end;
8: Pixels8[y,x]:=c;
end;
end;

function TFastDIB.GetPixel(y,x:Integer):TFColor;
var
w: Word;
d: DWord;
begin
case Bpp of
1,4,8: Result:=Colors[PixelsB[y,x]].c;
16:
begin
w:=Pixels16[y,x];
Result.b:=Scale8(w and BMask,Bpb);
Result.g:=Scale8(w and GMask shr GShl,Bpg);
Result.r:=Scale8(w and RMask shr RShl,Bpr);
end;
24: Result:=Pixels24[y,x];
32:
if Compression=0 then Result:=Pixels32[y,x].c else
begin
d:=Pixels32[y,x].i;
Result.b:=Scale8(d and BMask,Bpb);
Result.g:=Scale8(d and GMask shr GShl,Bpg);
Result.r:=Scale8(d and RMask shr RShl,Bpr);
end;
end;
end;

function TFastDIB.GetPixelB(y,x:Integer):Byte;
var
mo: Byte;
begin
case Bpp of
1:
begin
mo:=(x and 7)xor 7;
Result:=Pixels8[y,x shr 3]and(1 shl mo)shr mo;
end;
4: if(x and 1)=0 then Result:=Pixels8[y,x shr 1]shr 4 else Result:=Pixels8[y,x shr 1]and 15;
8: Result:=Pixels8[y,x];
else Result:=0;
end;
end;

procedure TFastDIB.SetSize(fWidth,fHeight:Integer;fBpp:Byte);
begin
SetInterface(nil,fWidth,fHeight,fBpp,0,0,0);
end;

procedure TFastDIB.SetSizeEx(fWidth,fHeight:Integer;fBpp,fBpr,fBpg,fBpb:Byte);
begin
SetInterface(nil,fWidth,fHeight,fBpp,fBpr,fBpg,fBpb);
end;

procedure TFastDIB.SetSizeIndirect(bmInfo:TBMInfo);
var
r,g,b: DWord;
begin
if(bmInfo.Header.Compression=1)or(bmInfo.Header.Compression=2)then
if(bmInfo.RMask<>0)or(bmInfo.GMask<>0)or(bmInfo.BMask<>0)then
bmInfo.Header.Compression:=3 else bmInfo.Header.Compression:=0;
if((bmInfo.Header.BitCount=16)or(bmInfo.Header.BitCount=32))
and(bmInfo.Header.Compression=3)then
MaskToInt(bmInfo.RMask,bmInfo.GMask,bmInfo.BMask,r,g,b)else
begin
r:=0; g:=0; b:=0;
end;
if bmInfo.Header.BitCount<=8 then Colors^:=bmInfo.Colors;
SetInterface(nil,bmInfo.Header.Width,bmInfo.Header.Height,bmInfo.Header.BitCount,r,g,b);
end;

procedure TFastDIB.SetInterface(fBitsointer;fWidth,fHeight:Integer;fBpp,fBpr,fBpg,fBpb:Byte);
var
x,i: Integer;
sDC: Windows.HDC;
begin
if fBpp=0 then
begin
sDC:=GetDC(0);
fBpp:=GetDeviceCaps(sDC,BITSPIXEL);
ReleaseDC(0,sDC);
if fBpp=16 then
begin
fBpr:=5;
fBpg:=Get16Bpg;
fBpb:=5;
end else if fBpp=32 then
begin
fBpr:=8;
fBpg:=8;
fBpb:=8;
end;
end;

if(fBpr=0)and(fBpg=0)and(fBpb=0)then
begin
Compression:=0;
if fBpp=16 then
begin
fBpr:=5;
fBpg:=5;
fBpb:=5;
end else if fBpp=32 then
begin
fBpr:=8;
fBpg:=8;
fBpb:=8;
end;
end else Compression:=3;

if(fBpp=16)or(fBpp=32)then IntToMask(fBpr,fBpg,fBpb,Info.RMask,Info.GMask,Info.BMask);

if((fBits=nil)and(fWidth=Width)and(fHeight=Height)and(fBpp=Bpp)and(fBpr=Bpr)and(fBpg=Bpg)and(fBpb=Bpb))and (UseGDI and(hDC<>0)) then Exit;

Width:=fWidth; Height:=fHeight;
AbsHeight:=Abs(fHeight); Bpp:=fBpp;
Bpr:=fBpr; Bpg:=fBpg;
Bpb:=fBpb; GShl:=Bpb;
RShl:=Bpb+Bpg;

if Bpb<8 then BShr:=8-Bpb else BShr:=0;
if Bpg<8 then GShr:=8-Bpg else GShr:=0;
if Bpr<8 then RShr:=8-Bpr else RShr:=0;

case Bpp of
1:
begin
x:=(Width+7)and -8;
BWidth:=((x+31)and -32)shr 3;
Gap:=BWidth-(x shr 3);
end;
4:
begin
x:=((Width shl 2)+7)and -8;
BWidth:=((x+31)and -32)shr 3;
Gap:=BWidth-(x shr 3);
end;
8:
begin
BWidth:=(((Width shl 3)+31)and -32)shr 3;
Gap:=BWidth-Width;
end;
16:
begin
BWidth:=(((Width shl 4)+31)and -32)shr 3;
Gap:=BWidth-(Width shl 1);
end;
24:
begin
BWidth:=(((Width*24)+31)and -32)shr 3;
Gap:=BWidth-((Width shl 1)+Width);
end;
32:
begin
BWidth:=(((Width shl 5)+31)and -32)shr 3;
Gap:=0;
end;
end;

Size:=AbsHeight*BWidth;

if(fBits<>nil)then Bits:=fBits else
begin
if(hDC<>0)and FreeDC then DeleteDC(hDC);
if(Handle<>0)and FreeHandle then DeleteObject(Handle);
if(hPen<>0)then DeleteObject(hPen);
if(hFont<>0)then DeleteObject(hFont);
if(hBrush<>0)then DeleteObject(hBrush);

if UseGDI then
begin
if(Bits<>nil)and FreeBits then ReallocMem(Bits,0);
Handle:=CreateDIB(0,@Info,0,Bits,0,0);
hDC:=CreateCompatibleDC(0);
SelectObject(hDC,Handle);
FreeBits:=False;
FreeDC:=True;
FreeHandle:=True;
end else
begin
if not FreeBits then Bits:=nil;
ReallocMem(Bits,Size);
FreeBits:=True;
FreeDC:=False;
FreeHandle:=False;
Handle:=0;
hDC:=0;
end;
end;

ReallocMem(Scanlines,AbsHeight shl 2);
Pixels8:=Pointer(Scanlines);
Pixels16:=Pointer(Scanlines);
Pixels24:=Pointer(Scanlines);
Pixels32:=Pointer(Scanlines);

if AbsHeight>0 then
begin
x:=Integer(Bits);
for i:=0 to AbsHeight-1 do
begin
Scanlines:=Ptr(x);
Inc(x,BWidth);
end;
end;
end;

procedure TFastDIB.SetInterfaceIndirect(fBitsointer;bmInfo:TBMInfo);
var
r,g,b: DWord;
begin
if(bmInfo.Header.Compression=1)or(bmInfo.Header.Compression=2)then
if(bmInfo.RMask<>0)or(bmInfo.GMask<>0)or(bmInfo.BMask<>0)then
bmInfo.Header.Compression:=3 else bmInfo.Header.Compression:=0;
if((bmInfo.Header.BitCount=16)or(bmInfo.Header.BitCount=32))
and(bmInfo.Header.Compression=3)then
MaskToInt(bmInfo.RMask,bmInfo.GMask,bmInfo.BMask,r,g,b)else
begin
r:=0; g:=0; b:=0;
end;
if bmInfo.Header.BitCount<=8 then Colors^:=bmInfo.Colors;
SetInterface(fBits,bmInfo.Header.Width,bmInfo.Header.Height,bmInfo.Header.BitCount,r,g,b);
end;

procedure TFastDIB.SetSubset(Bmp:TFastDIB;x,y,w,h:Integer);
var
xOff,i: Integer;
begin
if(Bmp.Bits=nil)or(x>=Bmp.Width)or(y>=Bmp.AbsHeight)then Exit;

if Bmp.Height>0 then y:=Bmp.AbsHeight-h-y;

if x<0 then
begin
Inc(w,x);
x:=0;
end;

if y<0 then
begin
Inc(h,y);
y:=0;
end;

if w+x>=Bmp.Width then w:=Bmp.Width-x;
if h+y>=Bmp.AbsHeight then h:=Bmp.AbsHeight-y;

if(w<=0)or(h<=0)then Exit;

xOff:=0;
case Bmp.Bpp of
1: xOff:=x shr 3;
4: xOff:=x shr 1;
8: xOff:=x;
16: xOff:=x shl 1;
24: xOff:=x*3; // lea xOff,[x+x*2] ! (cool)
32: xOff:=x shl 2;
end;

Bits:=Ptr(Integer(Bmp.Scanlines[y])+xOff);
SetInterface(Bits,w,h,Bmp.Bpp,Bmp.Bpr,Bmp.Bpg,Bmp.Bpb);
Size:=0;
Dec(BWidth,Gap);
Gap:=Bmp.BWidth-BWidth;
Inc(BWidth,Gap);
xOff:=Integer(Bits);
Colors:=Bmp.Colors;
hDC:=Bmp.hDC;
FreeDC:=False;
Handle:=Bmp.Handle;
FreeHandle:=False;
for i:=0 to AbsHeight-1 do
begin
Scanlines:=Ptr(xOff);
Inc(xOff,BWidth);
end;
end;

procedure TFastDIB.MakeCopy(Bmp:TFastDIB;CopyBits:Boolean);
begin
SetSizeIndirect(Bmp.Info);
if CopyBits then Move(Bmp.Bits^,Bits^,Size);
end;

procedure TFastDIB.LoadFromHandle(hBmp:HBITMAP);
var
dsInfo: TDIBSection;
BmInfo: TBMInfo;
begin
if GetObject(hBmp,SizeOf(dsInfo),@dsInfo)=84 then
begin
Move(dsInfo.dsBmih, BmInfo.Header, SizeOf(dsInfo.dsBmih));
SetSizeIndirect(BmInfo);
// SetSizeIndirect(PBMInfo(@dsInfo.dsBmih)^);
if dsInfo.dsBmih.biCompression=1 then DecodeRLE8(Self,dsInfo.dsBm.bmBits)
else if dsInfo.dsBmih.biCompression=2 then DecodeRLE4(Self,dsInfo.dsBm.bmBits)
else Move(dsInfo.dsBm.bmBits^,Bits^,dsInfo.dsBmih.biSizeImage);
if Bpp<=8 then
begin
GetDIBits(hDC,hBmp,0,0,nil,PBitmapInfo(@Info)^,0);
UpdateColors;
end;
end else
begin
SetSize(dsInfo.dsBm.bmWidth,dsInfo.dsBm.bmHeight,0);
GetDIBits(hDC,hBmp,0,AbsHeight,Bits,PBitmapInfo(@Info)^,0);
if Bpp<=8 then UpdateColors;
end;
end;

procedure TFastDIB.LoadFromFile(FileName:string);
var
i: DWord;
Buffer: Pointer;
bmInfo: TBMInfo;
hFile: Windows.HFILE;
fBits,xSize,fSize: DWord;
begin
hFile:=CreateFile(PChar(FileName),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);
fSize:=GetFileSize(hFile,nil);
xSize:=fSize;
if xSize>1078 then xSize:=1078;
GetMem(Buffer,1078);
ReadFile(hFile,Buffer^,xSize,i,nil);
fBits:=LoadHeader(Buffer,bmInfo);
SetSizeIndirect(bmInfo);
SetFilePointer(hFile,fBits-xSize,nil,FILE_CURRENT);
if(bmInfo.Header.Compression=1)or(bmInfo.Header.Compression=2)then xSize:=PDWord(Integer(Buffer)+2)^-fBits else
if fSize-fBits > Size then xSize:=Size else xSize:=fSize-fBits;
if(bmInfo.Header.Compression=0)or(bmInfo.Header.Compression=3)then
ReadFile(hFile,Bits^,xSize,i,nil)else
begin
ReAllocMem(Buffer,xSize);
ReadFile(hFile,Buffer^,xSize,i,nil);
if bmInfo.Header.Compression=1 then DecodeRLE8(Self,Buffer) else DecodeRLE4(Self,Buffer);
end;
CloseHandle(hFile);
FreeMem(Buffer);
end;

procedure TFastDIB.LoadFromRes(hInst:HINST;ResID,ResTypeChar);
var
pMem: Pointer;
bmInfo: TBMInfo;
fSize,fBits: DWord;
begin
pMem:=LockResource(LoadResource(hInst,FindResource(hInst,ResID,ResType)));
if pMem<>nil then
begin
fBits:=LoadHeader(pMem,bmInfo);
fSize:=PDWord(pMem)^-DWord(fBits);
SetSizeIndirect(bmInfo);
if Size < fSize then fSize:=Size;
if bmInfo.Header.Compression=1 then DecodeRLE8(Self,Ptr(DWord(pMem)+fBits))
else if bmInfo.Header.Compression=2 then DecodeRLE4(Self,Ptr(DWord(pMem)+fBits))
else Move(Ptr(DWord(pMem)+fBits)^,Bits^,fSize);
end;
end;

procedure TFastDIB.LoadFromClipboard;
var
hMem,i: Integer;
pMem: PBMInfo;
begin
if OpenClipboard(0) then
begin
hMem:=GetClipboardData(CF_DIB);
if hMem<>0 then
begin
pMem:=GlobalLock(hMem);
SetSizeIndirect(pMem^);
if pMem.Header.BitCount<=8 then i:=40+((1 shl pMem.Header.BitCount)shl 2)else
if(((pMem.Header.BitCount=16)or(pMem.Header.BitCount=32))and(pMem.Header.Compression=3))then i:=52 else i:=40;
if Bpp<=8 then Move(pMem.Colors,Colors^,(1 shl Bpp)shl 2);
if pMem.Header.Compression=1 then DecodeRLE8(Self,Ptr(Integer(pMem)+i))
else if pMem.Header.Compression=2 then DecodeRLE4(Self,Ptr(Integer(pMem)+i))
else Move(Ptr(Integer(pMem)+i)^,Bits^,pMem.Header.SizeImage);
GlobalUnlock(hMem);
end;
CloseClipboard;
end;
end;

procedure TFastDIB.UpdateColors;
begin
SetDIBColorTable(hDC,0,1 shl Bpp,Colors^);
end;

procedure TFastDIB.Draw(fDC:HDC;x,y:Integer);
begin
if hDC=0 then
StretchDIBits(fDC,x,y,Width,AbsHeight,0,0,
Width,AbsHeight,Bits,PBitmapInfo(@Info)^,0,SRCCOPY)
else BitBlt(fDC,x,y,Width,AbsHeight,hDC,0,0,SRCCOPY);
end;

procedure TFastDIB.Stretch(fDC:HDC;x,y,w,h:Integer);
begin
if hDC=0 then
StretchDIBits(fDC,x,y,w,h,0,0,
Width,AbsHeight,Bits,PBitmapInfo(@Info)^,0,SRCCOPY)
else StretchBlt(fDC,x,y,w,h,hDC,0,0,Width,AbsHeight,SRCCOPY);
end;

procedure TFastDIB.DrawRect(fDC:HDC;x,y,w,h,sx,sy:Integer);
begin
if hDC=0 then
StretchDIBits(fDC,x,y,w,h,sx,sy,w,h,Bits,PBitmapInfo(@Info)^,0,SRCCOPY)
else BitBlt(fDC,x,y,w,h,hDC,sx,sy,SRCCOPY);
end;

procedure TFastDIB.StretchRect(fDC:HDC;x,y,w,h,sx,sy,sw,sh:Integer);
begin
if hDC=0 then
StretchDIBits(fDC,x,y,w,h,sx,sy,sw,sh,Bits,PBitmapInfo(@Info)^,0,SRCCOPY)
else StretchBlt(fDC,x,y,w,h,hDC,sx,sy,sw,sh,SRCCOPY);
end;

procedure TFastDIB.PlgDraw(fDC:HDC;x1,y1,x2,y2,x3,y3:Integer);
var
Pts: array[0..2]of TPoint;
begin
Pts[0].x:=x1; Pts[0].y:=y1;
Pts[1].x:=x2; Pts[1].y:=y2;
Pts[2].x:=x3; Pts[2].y:=y3;
PlgBlt(fDC,Pts,hDC,0,0,Width,AbsHeight,0,0,0);
end;

procedure TFastDIB.MaskDraw(fDC:HDC;x,y:Integer;Mono:TFastDIB);
begin
MaskBlit(fDC,x,y,Width,AbsHeight,hDC,0,0,Mono.Handle,0,0,$CCAA0029);
end;

procedure TFastDIB.MaskRect(fDC:HDC;x,y,w,h,sx,sy,mx,my:Integer;Mono:TFastDIB);
begin
MaskBlit(fDC,x,y,Width,AbsHeight,hDC,sx,sy,Mono.Handle,mx,my,$CCAA0029);
end;

procedure TFastDIB.TransDraw(fDC:HDC;x,y:Integer;c:TFColor);
begin
TransBlit(fDC,x,y,Width,AbsHeight,hDC,0,0,Width,AbsHeight,ColorToInt(c));
end;

procedure TFastDIB.TransStretch(fDC:HDC;x,y,w,h:Integer;c:TFColor);
begin
TransBlit(fDC,x,y,w,h,hDC,0,0,Width,AbsHeight,ColorToInt(c));
end;

procedure TFastDIB.AlphaDraw(fDC:HDC;x,y:Integer;a:Byte;hasAlpha:Boolean);
var
Blend: TBlendFunction;
begin
Blend.BlendOp:=0;
Blend.BlendFlags:=0;
Blend.Alpha:=a;
Blend.Format:=Integer(hasAlpha);
AlphaBlit(fDC,x,y,Width,AbsHeight,hDC,0,0,Width,AbsHeight,Blend);
end;

procedure TFastDIB.AlphaStretch(fDC:HDC;x,y,w,h:Integer;a:Byte;hasAlpha:Boolean);
var
Blend: TBlendFunction;
begin
Blend.BlendOp:=0;
Blend.BlendFlags:=0;
Blend.Alpha:=a;
Blend.Format:=Integer(hasAlpha);
AlphaBlit(fDC,x,y,w,h,hDC,0,0,Width,AbsHeight,Blend);
end;

procedure TFastDIB.TileDraw(fDC:HDC;x,y,w,h:Integer);
var
hBmp: HBITMAP;
wd,hd: Integer;
memDC: Windows.HDC;
begin
memDC:=CreateCompatibleDC(fDC);
hBmp:=CreateCompatibleBitmap(fDC,w,h);
SelectObject(memDC,hBmp);
Draw(memDC,0,0);
wd:=Width;
hd:=AbsHeight;
while wd<w do
begin
BitBlt(memDC,wd,0,wd shl 1,h,memDC,0,0,SRCCOPY);
Inc(wd,wd);
end;
while hd<h do
begin
BitBlt(memDC,0,hd,w,hd shl 1,memDC,0,0,SRCCOPY);
Inc(hd,hd);
end;
BitBlt(fDC,x,y,w,h,memDC,0,0,SRCCOPY);
DeleteDC(memDC);
DeleteObject(hBmp);
end;

procedure TFastDIB.SetPen(Style,Width,ColorWord);
begin
hPen:=CreatePen(Style,Width,Color);
DeleteObject(SelectObject(hDC,hPen));
end;

procedure TFastDIB.SetBrush(Style,Hatch,ColorWord);
var
Brush: TLOGBRUSH;
begin
Brush.lbStyle:=Style;
Brush.lbHatch:=Hatch;
Brush.lbColor:=Color;
hBrush:=CreateBrushIndirect(Brush);
DeleteObject(SelectObject(hDC,hBrush));
end;

procedure TFastDIB.SetFont(Font:string;Size:Integer);
begin
hFont:=CreateFont(Size,0,0,0,0,0,0,0,0,0,0,0,0,PChar(Font));
DeleteObject(SelectObject(hDC,hFont));
end;

procedure TFastDIB.SetFontEx(Font:string;Width,Height,Weight:Integer;Italic,Underline,Strike:Boolean);
var
LogFont: TLOGFONT;
begin
FillChar(LogFont,SizeOf(LogFont),0);
with LogFont do
begin
lfHeight:=Height;
lfWidth:=Width;
lfWeight:=Weight;
lfItalic:=Byte(Italic);
lfUnderline:=Byte(Underline);
lfStrikeOut:=Byte(Strike);
Move(Font[1],lfFaceName,Length(Font));
end;
hFont:=CreateFontIndirect(LogFont);
DeleteObject(SelectObject(hDC,hFont));
end;

procedure TFastDIB.SetTextColor(ColorWord);
begin
Windows.SetTextColor(hDC,Color);
end;

procedure TFastDIB.SetTransparent(Transparent:Boolean);
begin
if Transparent then SetBkMode(hDC,1) else SetBkMode(hDC,2);
end;

procedure TFastDIB.SetBkColor(ColorWord);
begin
Windows.SetBkColor(hDC,Color);
end;

procedure TFastDIB.Ellipse(x1,y1,x2,y2:Integer);
begin
Windows.Ellipse(hDC,x1,y1,x2,y2);
end;

procedure TFastDIB.FillRect(Rect:TRect);
begin
Windows.FillRect(hDC,Rect,hBrush);
end;

procedure TFastDIB.LineTo(x,y:Integer);
begin
Windows.LineTo(hDC,x,y);
end;

procedure TFastDIB.MoveTo(x,y:Integer);
begin
MoveToEx(hDC,x,y,nil);
end;

procedure TFastDIB.Polygon(Points:array of TPoint);
begin
Windows.Polygon(hDC,Points,High(Points)+1);
end;

procedure TFastDIB.Polyline(Points:array of TPoint);
begin
Windows.Polyline(hDC,Points,High(Points)+1);
end;

procedure TFastDIB.Rectangle(x1,y1,x2,y2:Integer);
begin
Windows.Rectangle(hDC,x1,y1,x2,y2);
end;

procedure TFastDIB.TextOut(x,y:Integer;Text:string);
begin
Windows.TextOut(hDC,x,y,PChar(Text),Length(Text));
end;

procedure TFastDIB.DrawText(Text:string;Rect:TRect;Flags:Integer);
begin
Windows.DrawText(hDC,PChar(Text),Length(Text),Rect,Flags);
end;

procedure TFastDIB.Clear(c:TFColor);
begin
FastDIB.Clear(Self,c);
end;

procedure TFastDIB.ClearB(cWord);
begin
FastDIB.ClearB(Self,c);
end;

procedure TFastDIB.SaveToClipboard;
var
pMem: Pointer;
i,hMem: DWord;
begin
if Bpp<=8 then i:=40+((1 shl Bpp)shl 2)else
if(((Bpp=16)or(Bpp=32))and(Compression=3))then i:=52 else i:=40;
hMem:=GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE,Size+i);
pMem:=GlobalLock(hMem);
Move(Info,pMem^,i);
Move(Bits^,Ptr(DWord(pMem)+i)^,Size);
GlobalUnlock(hMem);
OpenClipboard(0);
SetClipboardData(CF_DIB,hMem);
CloseClipboard;
end;

procedure TFastDIB.SaveToFile(FileName:string);
var
cSize,i: DWord;
hFile: Windows.HFILE;
fHead: TBitmapFileHeader;
begin
hFile:=CreateFile(PChar(FileName),GENERIC_WRITE,0,nil,CREATE_ALWAYS,0,0);
if Info.Header.ClrUsed<>0 then cSize:=(Info.Header.ClrUsed shl 2)
else if Info.Header.Compression=BI_BITFIELDS then cSize:=12
else if Bpp<=8 then cSize:=(1 shl Bpp)shl 2
else cSize:=0;
fHead.bfType:=$4D42;
fHead.bfSize:=54+Size+cSize;
fHead.bfOffBits:=54+cSize;
WriteFile(hFile,fHead,SizeOf(fHead),i,nil);
WriteFile(hFile,Info,cSize+40,i,nil);
WriteFile(hFile,Bits^,Size,i,nil);
CloseHandle(hFile);
end;

procedure TFastDIB.CopyRect(Src:TFastDIB;x,y,w,h,sx,sy:Integer);
var
iy,pc,sc,b: Integer;
begin
if Height>0 then y:=AbsHeight-h-y;
if Src.Height>0 then sy:=Src.Height-h-sy;

if x<0 then
begin
Dec(sx,x);
Inc(w,x);
x:=0;
end;

if y<0 then
begin
Dec(sy,y);
Inc(h,y);
y:=0;
end;

if sx<0 then
begin
Dec(x,sx);
Inc(w,sx);
sx:=0;
end;

if sy<0 then
begin
Dec(y,sy);
Inc(h,sy);
sy:=0;
end;

if(sx<Src.Width)and(sy<Src.AbsHeight)and(x<Width)and(y<AbsHeight)then
begin

if w+sx>=Src.Width then w:=Src.Width-sx;
if h+sy>=Src.AbsHeight then h:=Src.AbsHeight-sy;
if w+x>=Width then w:=Width-x;
if h+y>=AbsHeight then h:=AbsHeight-y;

if(Bpp>=8)and(Bpp=Src.Bpp)then
begin

b:=w;
case Bpp of
16:
begin
b:=w shl 1;
x:=x shl 1;
sx:=sx shl 1;
end;
24:
begin
b:=w*3;
x:=x*3;
sx:=sx*3;
end;
32:
begin
b:=w shl 2;
x:=x shl 2;
sx:=sx shl 2;
end;
end;

pc:=Integer(Scanlines[y])+x;
sc:=Integer(Src.Scanlines[sy])+sx;

for iy:=0 to h-1 do
begin
Move(Ptr(sc)^,Ptr(pc)^,b);
Inc(pc,BWidth);
Inc(sc,Src.BWidth);
end;

end else
begin
for iy:=0 to h-1 do
for b:=0 to w-1 do
Pixels[y+iy,x+b]:=Src.Pixels[sy+iy,sx+b];
end;

end;
end;

procedure TFastDIB.FillColors(i1,i2:Integer;Keys:array of TFColor);
begin
FastDIB.FillColors(Colors,i1,i2,High(Keys)+1,PLine24(@Keys));
if hDC<>0 then UpdateColors;
end;

procedure TFastDIB.ShiftColors(i1,i2,Amount:Integer);
var
p: PFColorTable;
i: Integer;
begin
i:=i2-i1;
if(Amount<i)and(Amount>0)then
begin
GetMem(p,i shl 2);
Move(Colors[i1],p[0],i shl 2);
Move(p[0],Colors[i1+Amount],(i-Amount)shl 2);
Move(p[i-Amount],Colors[i1],Amount shl 2);
FreeMem(p);
end;
if hDC<>0 then UpdateColors;
end;

////////////////////////////////////////////////////////////////////////////////

procedure SetAlphaChannel(Bmp,Alpha:TFastDIB);
var
pb: PByte;
pc: PFColorA;
x,y: Integer;
begin
pb:=Pointer(Alpha.Bits);
pc:=Pointer(Bmp.Bits);
for y:=0 to Alpha.AbsHeight-1 do
begin
for x:=0 to Alpha.Width-1 do
begin
pc^.a:=pb^;
Inc(pc);
Inc(pb);
end;
pc:=Ptr(Integer(pc)+Bmp.Gap);
Inc(pb,Alpha.Gap);
end;
end;

procedure MultiplyAlpha(Bmp:TFastDIB);
var
pc: PFColorA;
x,y,i: Integer;
begin
pc:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
i:=pc.a;
if i=0 then
begin
pc.b:=0;
pc.g:=0;
pc.r:=0;
end else if i<255 then
begin
pc.b:=(pc.b*i)shr 8;
pc.g:=(pc.g*i)shr 8;
pc.r:=(pc.r*i)shr 8;
end;
Inc(pc);
end;
pc:=Ptr(Integer(pc)+Bmp.Gap);
end;
end;

procedure SwapChannels24(Bmp:TFastDIB);
var
pc: PFColor;
x,y,z: Integer;
begin
pc:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
z:=pc.r;
pc.r:=pc.b;
pc.b:=z;
Inc(pc);
end;
pc:=Ptr(Integer(pc)+Bmp.Gap);
end;
end;

procedure SwapChannels32(Bmp:TFastDIB);
var
pc: PFColorA;
x,y,z: Integer;
begin
pc:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
z:=pc.r;
pc.r:=pc.b;
pc.b:=z;
Inc(pc);
end;
pc:=Ptr(Integer(pc)+Bmp.Gap);
end;
end;

procedure SwapChannels(Bmp:TFastDIB);
begin
case Bmp.Bpp of
24: SwapChannels24(Bmp);
32: SwapChannels32(Bmp);
end;
end;

procedure FillMem(Memointer;Size,Value:Integer);
asm
push edi
push ebx

mov ebx,edx
mov edi,eax
mov eax,ecx
mov ecx,edx
shr ecx,2
jz @word
rep stosd

@word:
mov ecx,ebx
and ecx,2
jz @byte
mov [edi],ax
add edi,2

@byte:
mov ecx,ebx
and ecx,1
jz @exit
mov [edi],al

@exit:
pop ebx
pop edi
end;

procedure Clear(Bmp:TFastDIB;c:TFColor);
begin
case Bmp.Bpp of
1,4,8: ClearB(Bmp,ClosestColor(Bmp.Colors,(1 shl Bmp.Bpp)-1,c));
16: ClearB(Bmp,c.r shr Bmp.RShr shl Bmp.RShl or
c.g shr Bmp.GShr shl Bmp.GShl or
c.b shr Bmp.BShr);
24: ClearB(Bmp,PDWord(@c)^);
32: if Bmp.Compression=0 then ClearB(Bmp,PDWord(@c)^) else
ClearB(Bmp,c.r shr Bmp.RShr shl Bmp.RShl or
c.g shr Bmp.GShr shl Bmp.GShl or
c.b shr Bmp.BShr);
end;
end;

procedure ClearB(Bmp:TFastDIB;cWord);
var
i: Integer;
pc: PFColor;
begin
if(Bmp.Bpp=1)and(c=1)then c:=15;
if Bmp.Bpp<=4 then c:=c or c shl 4;
if Bmp.Bpp<=8 then
begin
c:=c or c shl 8;
c:=c or c shl 16;
end else if Bmp.Bpp=16 then c:=c or c shl 16;
if Bmp.Bpp=24 then
begin
pc:=Pointer(Bmp.Bits);
for i:=0 to Bmp.Width-1 do
begin
pc^:=PFColor(@c)^;
Inc(pc);
end;
for i:=1 to Bmp.AbsHeight-1 do
Move(Bmp.Bits^,Bmp.Scanlines^,Bmp.BWidth-Bmp.Gap);
end else
begin
if Bmp.Size<>0 then FillMem(Bmp.Bits,Bmp.Size,c) else
for i:=0 to Bmp.AbsHeight-1 do
FillMem(Bmp.Scanlines,Bmp.BWidth-Bmp.Gap,c);
end;
end;

procedure DecodeRLE4(Bmp:TFastDIB;Dataointer);
procedure OddMove(Src,DstByte;Size:Integer);
begin
if Size=0 then Exit;
repeat
Dst^:=(Dst^ and $F0)or(Src^ shr 4);
Inc(Dst);
Dst^:=(Dst^ and $0F)or(Src^ shl 4);
Inc(Src);
Dec(Size);
until Size=0;
end;
procedure OddFill(MemByte;Size,Value:Integer);
begin
Value:=(Value shr 4)or(Value shl 4);
Mem^:=(Mem^ and $F0)or(Value and $0F);
Inc(Mem);
if Size>1 then FillChar(Mem^,Size,Value);
Mem^:=(Mem^ and $0F)or(Value and $F0);
end;
var
pb: PByte;
x,y,z,i: Integer;
begin
pb:=Data; x:=0; y:=0;
while y<Bmp.AbsHeight do
begin
if pb^=0 then
begin
Inc(pb);
z:=pb^;
case pb^ of
0: begin
Inc;
x:=0;
end;
1: Break;
2: begin
Inc(pb); Inc(x,pb^);
Inc(pb); Inc(y,pb^);
end;
else
begin
Inc(pb);
i:=(z+1)shr 1;
if(z and 2)=2 then Inc(i);
if((x and 1)=1)and(x+i<Bmp.Width)then
OddMove(pb,@Bmp.Pixels8[y,x shr 1],i)
else
Move(pb^,Bmp.Pixels8[y,x shr 1],i);
Inc(pb,i-1);
Inc(x,z);
end;
end;
end else
begin
z:=pb^;
Inc(pb);
if((x and 1)=1)and(x+z<Bmp.Width)then
OddFill(@Bmp.Pixels8[y,x shr 1],z shr 1,pb^)
else
FillChar(Bmp.Pixels8[y,x shr 1],z shr 1,pb^);
Inc(x,z);
end;
Inc(pb);
end;
end;

procedure DecodeRLE8(Bmp:TFastDIB;Dataointer);
var
pb: PByte;
x,y,z,i,s: Integer;
begin
pb:=Data; y:=0; x:=0;
while y<Bmp.AbsHeight do
begin
if pb^=0 then
begin
Inc(pb);
case pb^ of
0: begin
Inc;
x:=0;
end;
1: Break;
2: begin
Inc(pb); Inc(x,pb^);
Inc(pb); Inc(y,pb^);
end;
else
begin
i:=pb^;
s:=(i+1)and(not 1);
z:=s-1;
Inc(pb);
if x+s>Bmp.Width then s:=Bmp.Width-x;
Move(pb^,Bmp.Pixels8[y,x],s);
Inc(pb,z);
Inc(x,i);
end;
end;
end else
begin
i:=pb^; Inc(pb);
if i+x>Bmp.Width then i:=Bmp.Width-x;
FillChar(Bmp.Pixels8[y,x],i,pb^);
Inc(x,i);
end;
Inc(pb);
end;
end;

procedure FillColors(PalFColorTable;i1,i2,nKeys:Integer;KeysLine24);
var
pc: PFColorA;
c1,c2: TFColor;
i,n,cs,w1,w2,x,ii: Integer;
begin
i:=0;
n:=i2-i1;
Dec(nKeys);
ii:=(nKeys shl 16)div n;
pc:=@Pal[i1];
for x:=0 to n-1 do
begin
cs:=i shr 16;
c1:=Keys[cs];
if cs<nKeys then Inc(cs);
c2:=Keys[cs];
w1:=((not i)and $FFFF)+1;
w2:=i and $FFFF;
if(w1<(ii-w1))then pc.c:=c2 else
if(w2<(ii-w2))then pc.c:=c1 else
begin
pc.b:=((c1.b*w1)+(c2.b*w2))shr 16;
pc.g:=((c1.g*w1)+(c2.g*w2))shr 16;
pc.r:=((c1.r*w1)+(c2.r*w2))shr 16;
end;
Inc(i,ii);
Inc(pc);
end;
pc.c:=c2;
end;

function ClosestColor(PalFColorTable;Max:Integer;c:TFColor):Byte;
var
n: Byte;
pc: PFColorA;
i,x,d: Integer;
begin
x:=765; n:=0;
pc:=Pointer(Pal);
for i:=0 to Max do
begin
if pc.b>c.b then d:=pc.b-c.b else d:=c.b-pc.b;
if pc.g>c.g then Inc(d,pc.g-c.g) else Inc(d,c.g-pc.g);
if pc.r>c.r then Inc(d,pc.r-c.r) else Inc(d,c.r-pc.r);
if d<x then
begin
x:=d;
n:=i;
end;
Inc(pc);
end;
Result:=n;
end;

function LoadHeader(Dataointer;var bmInfo:TBMInfo):Integer;
var
i: Integer;
begin
if PDWord(Ptr(Integer(Data)+14))^=40 then
Move(Ptr(Integer(Data)+14)^,bmInfo,SizeOf(bmInfo))
else if PDWord(Ptr(Integer(Data)+14))^=12 then
with PBitmapCoreInfo(Ptr(Integer(Data)+14))^ do
begin
FillChar(bmInfo,SizeOf(bmInfo),0);
bmInfo.Header.Width:=bmciHeader.bcWidth;
bmInfo.Header.Height:=bmciHeader.bcHeight;
bmInfo.Header.BitCount:=bmciHeader.bcBitCount;
if bmciHeader.bcBitCount<=8 then
for i:=0 to (1 shl bmciHeader.bcBitCount)-1 do
bmInfo.Colors:=PFColorA(@bmciColors)^;
end;
Result:=PDWord(Ptr(Integer(Data)+10))^;
end;

function PackedDIB(Bmp:TFastDIB)ointer;
var
i: DWord;
begin
if Bmp.Bpp<=8 then i:=40+((1 shl Bmp.Bpp)shl 2)else
if(((Bmp.Bpp=16)or(Bmp.Bpp=32))and(Bmp.Compression=3))then i:=52 else i:=40;
GetMem(Result,Bmp.Size+i);
Move(Bmp.Info,Result^,i);
Move(Bmp.Bits^,Ptr(DWord(Result)+i)^,Bmp.Size);
end;

function Count1(Bmp:TFastDIB):Integer;
var
pb: PByte;
w,c,x,y: Integer;
begin
Result:=2;
pb:=Pointer(Bmp.Bits); c:=pb^;
if(c<>0)and(c<>255)then Exit;
w:=(Bmp.Width div 8)-1;
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to w do
begin
if pb^<>c then Exit;
Inc(pb);
end;
Inc(pb,Bmp.Gap);
end;
Result:=1;
end;

function Count4(Bmp:TFastDIB):Integer;
var
pb,pc: PByte;
x,y,w: Integer;
Check: array[0..15]of Byte;
begin
Result:=0;
FillChar(Check,SizeOf(Check),0);
pb:=Pointer(Bmp.Bits);
w:=(Bmp.Width div 2)-1;
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to w do
begin
pc:=@Check[pb^ shr 4];
if pc^=0 then
begin
Inc(Result);
pc^:=1;
end;
pc:=@Check[pb^ and 15];
if pc^=0 then
begin
Inc(Result);
pc^:=1;
end;
if Result=16 then Exit;
Inc(pb);
end;
Inc(pb,Bmp.Gap);
end;
end;

function Count8(Bmp:TFastDIB):Integer;
var
x,y: Integer;
pb,pc: PByte;
Check: array[Byte]of Byte;
begin
Result:=0;
FillChar(Check,SizeOf(Check),0);
pb:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
pc:=@Check[pb^];
if pc^=0 then
begin
Inc(Result);
pc^:=1;
end;
if Result=256 then Exit;
Inc(pb);
end;
Inc(pb,Bmp.Gap);
end;
end;

function Count16(Bmp:TFastDIB):Integer;
var
pw: PWord;
pc: PByte;
x,y: Integer;
Check: array[Word]of Byte;
begin
Result:=0;
FillChar(Check,SizeOf(Check),0);
pw:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
pc:=@Check[pw^];
if pc^=0 then
begin
Inc(Result);
pc^:=1;
end;
Inc(pw);
end;
pw:=Ptr(Integer(pw)+Bmp.Gap);
end;
end;

function Count24(Bmp:TFastDIB):Integer;
type
PCheck =^TCheck;
TCheck = array[Byte,Byte,0..31]of Byte;
var
pb: PByte;
pc: PFColor;
Check: PCheck;
x,y,c: Integer;
begin
Result:=0;
New(Check);
FillChar(Check^,SizeOf(TCheck),0);
pc:=Pointer(Bmp.Bits);
for y:=0 to Bmp.AbsHeight-1 do
begin
for x:=0 to Bmp.Width-1 do
begin
pb:=@Check[pc.r,pc.g,pc.b shr 3];
c:=1 shl(pc.b and 7);
if(c and pb^)=0 then
begin
Inc(Result);
pb^:=pb^ or c;
end;
Inc(pc);
end;
pc:=Ptr(Integer(pc)+Bmp.Gap);
end;
Dispose(Check);
end;

function Count32(Bmp:TFastDIB):Integer;
type
PCheck =^TCheck;
TCheck = array[Byte,Byte,0..31]of Byte;
var
pb: PByte;
pc: PFColorA;
i,c: Integer;
Check: PCheck;
begin
Result:=0;
New(Check);
FillChar(Check^,SizeOf(TCheck),0);
pc:=Pointer(Bmp.Bits);
for i:=0 to(Bmp.Size shr 2)-1 do
begin
pb:=@Check[pc.r,pc.g,pc.b shr 3];
c:=1 shl(pc.b and 7);
if(c and pb^)=0 then
begin
Inc(Result);
pb^:=pb^ or c;
end;
Inc(pc);
end;
Dispose(Check);
end;

function CountColors(Bmp:TFastDIB)Word;
begin
case Bmp.Bpp of
1: Result:=Count1(Bmp);
4: Result:=Count4(Bmp);
8: Result:=Count8(Bmp);
16: Result:=Count16(Bmp);
24: Result:=Count24(Bmp);
32: Result:=Count32(Bmp);
else Result:=0;
end;
end;

procedure IntToMask(Bpr,Bpg,BpbWord;var RMsk,GMsk,BMskWord);
begin
BMsk:=(1 shl Bpb)-1;
GMsk:=((1 shl(Bpb+Bpg))-1)and not BMsk;
if(Bpr+Bpg+Bpb)=32 then RMsk:=$FFFFFFFF else RMsk:=(1 shl(Bpr+Bpb+Bpg))-1;
RMsk:=RMsk and not(BMsk or GMsk);
end;

procedure MaskToInt(RMsk,GMsk,BMskWord;var Bpr,Bpg,BpbWord);
function CountBits(iWord)Word;
asm
bsr edx,eax
bsf ecx,eax
sub edx,ecx
inc edx
mov eax,edx
end;
begin
Bpb:=CountBits(BMsk);
Bpg:=CountBits(GMsk);
Bpr:=CountBits(RMsk);
end;

function UnpackColorTable(Table:TFPackedColorTable):TFColorTable;
var
i: Integer;
begin
for i:=0 to 255 do
Result.c:=Table;
end;

function PackColorTable(Table:TFColorTable):TFPackedColorTable;
var
i: Integer;
begin
for i:=0 to 255 do
Result:=Table.c;
end;

function FRGB(r,g,b:Byte):TFColor;
begin
Result.b:=b;
Result.g:=g;
Result.r:=r;
end;

function FRGBA(r,g,b,a:Byte):TFColorA;
begin
Result.b:=b;
Result.g:=g;
Result.r:=r;
Result.a:=a;
end;

function ColorToInt(c:TFColor)Word;
begin
Result:=c.b shl 16 or c.g shl 8 or c.r;
end;

function ColorToIntA(c:TFColorA)Word;
begin
Result:=c.b shl 24 or c.g shl 16 or c.r shl 8 or c.a;
end;

function IntToColor(iWord):TFColor;
begin
Result.b:=i shr 16;
Result.g:=i shr 8;
Result.r:=i;
end;

function IntToColorA(iWord):TFColorA;
begin
Result.a:=i shr 24;
Result.b:=i shr 16;
Result.g:=i shr 8;
Result.r:=i;
end;

function Scale8(i,n:Integer):Integer;
begin // Result:=(i*255)div([1 shl n]-1);
case n of
1: if Boolean(i) then Result:=255 else Result:=0;
2: Result:=(i shl 6)or(i shl 4)or(i shl 2)or i;
3: Result:=(i shl 5)or(i shl 2)or(i shr 1);
4: Result:=(i shl 4)or i;
5: Result:=(i shl 3)or(i shr 2);
6: Result:=(i shl 2)or(i shr 4);
7: Result:=(i shl 1)or(i shr 6);
else Result:=i;
end;
end;

function Get16Bpg:Byte;
var
c: DWord;
hBM: HBITMAP;
sDC,bDC: Windows.HDC;
begin
sDC:=GetDC(0);
bDC:=CreateCompatibleDC(sDC);
hBM:=CreateCompatibleBitmap(sDC,1,1);
SelectObject(bDC,hBM);
SetPixel(bDC,0,0,RGB(0,100,0));
c:=GetPixel(bDC,0,0);
DeleteDC(bDC);
DeleteObject(hBM);
ReleaseDC(0,sDC);
if GetGValue(c)>=100 then Result:=6 else Result:=5;
end;

procedure GetCPUInfo;
function HasCPUID:LongBool;
asm
pushfd
pop eax
mov ecx,eax
xor eax,$00200000
push eax
popfd
pushfd
pop eax
xor eax,ecx
end;

procedure CPUID(FlagWord;var Signature,FeaturesWord);
asm
push ebx
push esi
push edi
mov esi,edx
mov edi,ecx
db $0F,$A2 // cpuid
mov [esi],eax
mov [edi],edx
pop edi
pop esi
pop ebx
end;

function GetVendorID(VendorID:ShortString)Word;
asm
push edi
push ebx
push eax
xor eax,eax
db $0F,$A2 // cpuid
pop edi
mov [edi],Byte(12)
inc edi
push ecx
push edx
mov ecx,3
@loop:
mov [edi],bl
inc edi
mov [edi],bh
inc edi
shr ebx,16
mov [edi],bl
inc edi
mov [edi],bh
inc edi
pop ebx
dec ecx
jnz @loop
pop edi
end;
var
SysInfo: TSystemInfo;
Signature,Features: DWord;
begin
if HasCPUID then
begin
if GetVendorID(CPUInfo.VendorID) > 0 then
begin
// standard features
CPUID(1,Signature,Features);
CPUInfo.Family:=(Signature shr 8)and $0F;
CPUInfo.Model:=(Signature shr 4)and $0F;
if LongBool(Features and(1 shl 8)) then
CPUInfo.Features:=CPUInfo.Features + [cfCX8];
if LongBool(Features and(1 shl 15)) then
CPUInfo.Features:=CPUInfo.Features + [cfCMOV];
if LongBool(Features and(1 shl 23)) then
CPUInfo.Features:=CPUInfo.Features + [cfMMX];
if LongBool(Features and(1 shl 25)) then
CPUInfo.Features:=CPUInfo.Features + [cfSSE];
if LongBool(Features and(1 shl 26)) then
CPUInfo.Features:=CPUInfo.Features + [cfSSE2];
// extended features
CPUID($80000000,Signature,Features);
if Signature > $80000000 then
begin
CPUID($80000001,Signature,Features);
if LongBool(Features and(1 shl 22)) then
CPUInfo.Features:=CPUInfo.Features + [cfMMX2];
if LongBool(Features and(1 shl 31)) then
CPUInfo.Features:=CPUInfo.Features + [cf3DNow];
if LongBool(Features and(1 shl 30)) then
CPUInfo.Features:=CPUInfo.Features + [cf3DNow2];
end;
end;
end;
GetSystemInfo(SysInfo);
CPUInfo.CPUCount:=SysInfo.dwNumberOfProcessors;
end;

var
hMSIMG32: HINST;

initialization

GetCPUInfo;

//hMSIMG32:=LoadLibrary('msimg32.dll');
//@TransBlit:=GetProcAddress(hMSIMG32,'TransparentBlt');
//@AlphaBlit:=GetProcAddress(hMSIMG32,'AlphaBlend');

finalization

//FreeLibrary(hMSIMG32);

end.

谢谢老兄，能不能把FASTDIB里面的所有模块一起打个包发给我呢？

我也要一份哈，
邮箱地址: lqcros@126.com

看样子不错.

真服了楼上的了.

自己COPY一下.保存成 pas 就可以了.

不明白，FastDIB只调用了windows单元，还有什么模块？

有个FastFiles，是调用FastDIB的，FastFiles用到ijl.dll，收集了4个版本的ijl，
到 http://www.chinadbs.com/image/?ijl 下载
，贴上FastFiles：

unit FastFiles; // FastFiles - 1999~2001 G-Soft
// Updated: 5/07/2001
interface // http://gfody.com <gfody@home.com>

uses Windows, FastDIB, Classes;

const
jBufferMode = 1;
jReadHeader = 0;
jReadEntropy = 6;
jWriteImage = 8;
jWriteHeader = 10;
jWriteEntropy = 12;
jReadMode: array[0..4]of Byte = (2,14,16,18,20);

type
TJPGScale = (jsNone,jsHalf,jsQuarter,jsEighth,jsThumbnail);

TJPGProps = packed record
UseExProps: LongBool;
DIBBytes: Pointer;
DIBWidth: DWord;
DIBHeight: Integer;
DIBPadBytes: DWord;
DIBChannels: DWord;
DIBColor: Integer;
DIBSubsampling: Integer;
FileName: PChar;
JPGBytes: Pointer;
JPGSizeBytes: DWord;
JPGWidth: DWord;
JPGHeight: DWord;
JPGChannels: DWord;
JPGColor: Integer;
JPGSubsampling: Integer;
JPGThumbWidth: DWord;
JPGThumbHeight: DWord;
NeedsConvert: LongBool;
NeedsResample: LongBool;
Quality: DWord;
UselessCrap1: array[0..7]of Byte;
Rect: TRect;
IntelDCT: Boolean;
UselessCrap2: array[0..19922]of Byte;
Smooth: Boolean;
UselessCrap3: array[0..38]of Byte;
end;

TFastJPG = class
private
fBmp: TFastDIB;
procedure SetBitmap(Bmp:TFastDIB);
public
Props: TJPGProps;
Scale: TJPGScale;
err : Integer;
constructor Create;
destructor Destroy; override;
procedure FlushProps;
property Bitmap:TFastDIB read fBmp write SetBitmap;
procedure LoadFile(FileName:string);
procedure LoadStream(Stream:TStream);
procedure LoadRes(hInst:Integer;ResID,ResType:string);
procedure LoadMem(Memointer;Size:Integer);
procedure SaveFile(FileName:string);
procedure SaveStream(Stream:TStream);
function SaveMem(Memointer;Size:Integer):Integer;
end;

procedure LoadBMPFile(Bmp:TFastDIB;FileName:string);
procedure SaveBMPFile(Bmp:TFastDIB;FileName:string);
procedure LoadBMPStream(Bmp:TFastDIB;Stream:TStream);
procedure SaveBMPStream(Bmp:TFastDIB;Stream:TStream);

procedure LoadJPGFile(Bmp:TFastDIB;FileName:string;Smooth:Boolean);
procedure SaveJPGFile(Bmp:TFastDIB;FileName:string;Quality:Integer);
procedure LoadJPGStream(Bmp:TFastDIB;Stream:TStream;Smooth:Boolean);
procedure SaveJPGStream(Bmp:TFastDIB;Stream:TStream;Quality:Integer);
procedure LoadJPGMem(Bmp:TFastDIB;Memointer;Size:Integer;Smooth:Boolean);
procedure LoadJPGRes(Bmp:TFastDIB;hInst:Integer;ResID,ResType:string;Smooth:Boolean);
function SaveJPGMem(Bmp:TFastDIB;Memointer;Size:Integer;Quality:Integer):Integer;
function FindJPGEOI(MemByte;Size:Integer):Integer;

var
HasJPG: Boolean = False; // Intel Jpeg Library
JInit: function(Propsointer):Integer; stdcall;
JFree: function(Propsointer):Integer; stdcall;
JRead: function(Propsointer;Method:Integer):Integer; stdcall;
JWrite: function(Propsointer;Method:Integer):Integer; stdcall;

implementation

procedure LoadBMPFile(Bmp:TFastDIB;FileName:string);
begin
Bmp.LoadFromFile(FileName);
end;

procedure SaveBMPFile(Bmp:TFastDIB;FileName:string);
begin
Bmp.SaveToFile(FileName);
end;

procedure LoadBMPStream(Bmp:TFastDIB;Stream:TStream);
var
fBits,fSize: Integer;
Buffer: Pointer;
bmInfo: TBMInfo;
begin
fSize:=Stream.Size;
if fSize>1078 then fSize:=1078;
GetMem(Buffer,1078);
Stream.ReadBuffer(Buffer^,fSize);
fBits:=LoadHeader(Buffer,bmInfo);
Bmp.SetSizeIndirect(bmInfo);
Stream.Seek(fBits-fSize,soFromCurrent);
if(bmInfo.Header.Compression=1)or(bmInfo.Header.Compression=2)then fSize:=(PDWord(Integer(Buffer)+2)^-DWord(fBits))else
if Stream.Size-fBits > Integer(Bmp.Size) then fSize:=Bmp.Size else fSize:=Stream.Size-fBits;
if(bmInfo.Header.Compression=0)or(bmInfo.Header.Compression=3)then
Stream.ReadBuffer(Bmp.Bits^,fSize)else
begin
if Stream is TCustomMemoryStream then
begin
if bmInfo.Header.Compression=1 then
DecodeRLE8(Bmp,Ptr(Integer(TCustomMemoryStream(Stream).Memory)+fBits))else
DecodeRLE4(Bmp,Ptr(Integer(TCustomMemoryStream(Stream).Memory)+fBits));
end else
begin
ReAllocMem(Buffer,fSize);
Stream.ReadBuffer(Buffer^,fSize);
if bmInfo.Header.Compression=1 then DecodeRLE8(Bmp,Buffer) else DecodeRLE4(Bmp,Buffer);
end;
end;
FreeMem(Buffer);
end;

procedure SaveBMPStream(Bmp:TFastDIB;Stream:TStream);
var
cSize: Integer;
fHead: TBitmapFileHeader;
begin
if Bmp.Info.Header.ClrUsed<>0 then cSize:=(Bmp.Info.Header.ClrUsed shl 2)
else if Bmp.Info.Header.Compression=BI_BITFIELDS then cSize:=12
else if Bmp.Bpp<=8 then cSize:=(1 shl Bmp.Bpp)shl 2
else cSize:=0;
fHead.bfType:=$4D42;
fHead.bfSize:=54+Bmp.Size+DWord(cSize);
fHead.bfOffBits:=54+cSize;
Stream.WriteBuffer(fHead,SizeOf(fHead));
Stream.WriteBuffer(Bmp.Info,40+cSize);
Stream.WriteBuffer(Bmp.Bits^,Bmp.Size);
end;

procedure LoadJPGFile(Bmp:TFastDIB;FileName:string;Smooth:Boolean);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Smooth:=Smooth;
LoadFile(FileName);
Free;
end;
end;

procedure SaveJPGFile(Bmp:TFastDIB;FileName:string;Quality:Integer);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Quality:=Quality;
SaveFile(FileName);
Free;
end;
end;

procedure LoadJPGStream(Bmp:TFastDIB;Stream:TStream;Smooth:Boolean);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Smooth:=Smooth;
LoadStream(Stream);
Free;
end;
end;

procedure SaveJPGStream(Bmp:TFastDIB;Stream:TStream;Quality:Integer);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Quality:=Quality;
LoadStream(Stream);
Free;
end;
end;

procedure LoadJPGMem(Bmp:TFastDIB;Memointer;Size:Integer;Smooth:Boolean);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Smooth:=Smooth;
LoadMem(Mem,Size);
Free;
end;
end;

procedure LoadJPGRes(Bmp:TFastDIB;hInst:Integer;ResID,ResType:string;Smooth:Boolean);
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Smooth:=Smooth;
LoadRes(hInst,ResID,ResType);
Free;
end;
end;

function SaveJPGMem(Bmp:TFastDIB;Memointer;Size,Quality:Integer):Integer;
begin
if HasJPG then with TFastJPG.Create do
begin
Bitmap:=Bmp;
Props.Quality:=Quality;
Result:=SaveMem(Mem,Size);
Free;
end else Result:=0;
end;

function FindJPGEOI(MemByte;Size:Integer):Integer;
var
Count: Integer;
begin
Count:=1;
while(Size<>0)and(PWord(Mem)^<>$D9FF)do
begin
Inc(Mem);
Inc(Count);
Dec(Size);
end;
Result:=Count;
end;

// TFastJPG

constructor TFastJPG.Create;
begin
fBmp:= TFastDIB.Create;
FillChar(Props,SizeOf(Props),0);
err:=JInit(@Props);
end;

destructor TFastJPG.Destroy;
begin
fBmp.Free;
JFree(@Props);
inherited Destroy;
end;

procedure TFastJPG.FlushProps;
begin
JFree(@Props);
FillChar(Props,SizeOf(Props),0);
JInit(@Props);
end;

procedure TFastJPG.SetBitmap(Bmp:TFastDIB);
begin
fBmp:=Bmp;
Props.DIBBytes:=fBmp.Bits;
Props.DIBWidth:=fBmp.Width;
Props.DIBHeight:=-fBmp.Height;
Props.DIBPadBytes:=fBmp.Gap;
case fBmp.Bpp of
8:
begin
Props.DIBChannels:=1;
Props.DIBColor:=4;
end;
24:
begin
Props.DIBChannels:=3;
Props.DIBColor:=2;
end;
end;
end;

procedure TFastJPG.LoadFile(FileName:string);
var
w,h: Integer;
begin
Props.FileName:=PChar(FileName);
JRead(@Props,jReadHeader);

w:=Props.JPGWidth shr Byte(Scale);
h:=Props.JPGHeight shr Byte(Scale);
if Scale=jsThumbnail then
begin
w:=Props.JPGThumbWidth;
h:=Props.JPGThumbHeight;
end;

if(Props.JPGChannels=1)then
begin
Bitmap.SetSize(w,h,8);
Bitmap.FillColors(0,255,[tfBlack,tfWhite]);
Props.DIBChannels:=1;
Props.DIBColor:=4;
end else
begin
Bitmap.SetSize(w,h,24);
Props.DIBChannels:=3;
Props.DIBColor:=2;
end;

Props.DIBBytes:=Bitmap.Bits;
Props.DIBWidth:=Bitmap.Width;
Props.DIBHeight:=-Bitmap.Height;
Props.DIBPadBytes:=Bitmap.Gap;

JRead(@Props,jReadMode[Byte(Scale)]);
end;

procedure TFastJPG.LoadStream(Stream:TStream);
var
Buffer: Pointer;
BSize,JSize,Pos: Integer;
begin
Pos:=Stream.Position;
BSize:=Stream.Size-Pos;
if Stream is TCustomMemoryStream then
begin
JSize:=FindJPGEOI(Ptr(Integer(TCustomMemoryStream(Stream).Memory)+Pos),BSize);
LoadMem(Ptr(Integer(TCustomMemoryStream(Stream).Memory)+Pos),BSize);
Stream.Position:=Pos+JSize;
end else
begin
GetMem(Buffer,BSize);
Stream.Read(Buffer^,BSize);
JSize:=FindJPGEOI(Buffer,BSize);
LoadMem(Buffer,BSize);
Stream.Position:=Pos+JSize;
FreeMem(Buffer);
end;
end;

procedure TFastJPG.LoadRes(hInst:Integer;ResID,ResType:string);
var
pMem: Pointer;
hRes,Size: Integer;
begin
hRes:=FindResource(hInst,PChar(ResID),PChar(ResType));
Size:=SizeofResource(hInst,hRes);
pMem:=LockResource(LoadResource(hInst,hRes));
if pMem<>nil then LoadMem(pMem,Size);
end;

procedure TFastJPG.LoadMem(Memointer;Size:Integer);
var
w,h: Integer;
begin
Props.JPGBytes:=Mem;
Props.JPGSizeBytes:=Size;
JRead(@Props,jReadHeader or jBufferMode);

w:=Props.JPGWidth shr Byte(Scale);
h:=Props.JPGHeight shr Byte(Scale);
if Scale=jsThumbnail then
begin
w:=Props.JPGThumbWidth;
h:=Props.JPGThumbHeight;
end;

if(Props.JPGChannels=1)then
begin
Bitmap.SetSize(w,h,8);
Bitmap.FillColors(0,255,[tfBlack,tfWhite]);
Props.DIBChannels:=1;
Props.DIBColor:=4;
end else
begin
Bitmap.SetSize(w,h,24);
Props.DIBChannels:=3;
Props.DIBColor:=2;
end;

Props.DIBBytes:=Bitmap.Bits;
Props.DIBWidth:=Bitmap.Width;
Props.DIBHeight:=-Bitmap.Height;
Props.DIBPadBytes:=Bitmap.Gap;
JRead(@Props,jReadMode[Byte(Scale)]or jBufferMode);
end;

procedure TFastJPG.SaveFile(FileName:string);
begin
Props.DIBBytes:=Bitmap.Bits;
Props.DIBWidth:=Bitmap.Width;
Props.DIBHeight:=-Bitmap.Height;
Props.DIBPadBytes:=Bitmap.Gap;
if(Bitmap.Bpp=8)then
begin
Props.DIBChannels:=1;
Props.DIBColor:=4;
end;

Props.FileName:=PChar(FileName);
Props.JPGWidth:=Bitmap.Width;
Props.JPGHeight:=Bitmap.AbsHeight;

JWrite(@Props,jWriteImage)
end;

procedure TFastJPG.SaveStream(Stream:TStream);
var
Buffer: Pointer;
Size: Integer;
begin
GetMem(Buffer,Bitmap.Size);
Size:=SaveMem(Buffer,Bitmap.Size);
Stream.WriteBuffer(Buffer^,Size);
FreeMem(Buffer);
end;

function TFastJPG.SaveMem(Memointer;Size:Integer):Integer;
begin
Props.DIBBytes:=Bitmap.Bits;
Props.DIBWidth:=Bitmap.Width;
Props.DIBHeight:=-Bitmap.Height;
Props.DIBPadBytes:=Bitmap.Gap;
if(Bitmap.Bpp=8)then
begin
Props.DIBChannels:=1;
Props.DIBColor:=4;
end;

Props.JPGBytes:=Mem;
Props.JPGSizeBytes:=Size;
Props.JPGWidth:=Bitmap.Width;
Props.JPGHeight:=Bitmap.AbsHeight;

JWrite(@Props,jWriteImage or jBufferMode);
Result:=Props.JPGSizeBytes;
end;

procedure SetIJLCPUKey;
var
Key: HKEY;
CPUKey,Dummy: Integer;
begin
CPUKey:=0;

// determine Pentium, Pentium Pro, Pentium II
if CPUInfo.VendorID='GenuineIntel' then
if CPUInfo.Family=5 then CPUKey:=1 else if CPUInfo.Family=6 then
if CPUInfo.Model > 1 then CPUKey:=4 else CPUKey:=2;

// determine MMX, Pentium III, Pentium 4
if(cfMMX in CPUInfo.Features)and(CPUKey < 3)then CPUKey:=3;
if cfSSE in CPUInfo.Features then CPUKey:=5;
if cfSSE2 in CPUInfo.Features then CPUKey:=6;

RegCreateKeyEx(
HKEY_LOCAL_MACHINE,'SOFTWARE/Intel Corporation/PLSuite/IJLib',0,nil,
REG_OPTION_NON_VOLATILE,KEY_WRITE,nil,Key,@Dummy);

RegSetValueEx(Key,'USECPU',0,REG_DWORD,@CPUKey,4);
RegCloseKey(Key);
end;

var
hIJL: HINST;

initialization

hIJL:=LoadLibrary('ijl151.dll');
if hIJL<>0 then
begin
SetIJLCPUKey;
HasJPG:=True;

@JInit:=GetProcAddress(hIJL,'ijlInit');
@JFree:=GetProcAddress(hIJL,'ijlFree');
@JRead:=GetProcAddress(hIJL,'ijlRead');
@JWrite:=GetProcAddress(hIJL,'ijlWrite');
end;

finalization

FreeLibrary(hIJL);

end.

unit FastDraw; // FastDraw
// Updated: 2/03/2001
interface // http://gfody.com

{$R-}

uses Windows, FastDIB;

procedure GradientFill8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:Byte);
procedure GradientFill(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:TFColor);
procedure Line8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:Byte);
procedure Line(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
procedure SmoothLine8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:Byte);
procedure SmoothLine(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
procedure Polyline8(Bmp:TFastDIB;pnts:array of TPoint;c:Byte);
procedure Polyline(Bmp:TFastDIB;pnts:array of TPoint;c:TFColor);
procedure SmoothPolyline8(Bmp:TFastDIB;pnts:array of TPoint;c:Byte);
procedure SmoothPolyline(Bmp:TFastDIB;pnts:array of TPoint;c:TFColor);

implementation

procedure GradientFill8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:Byte);
var
pc: PByte;
xc,yc,t,t2,z,iz,p2,p,dx,xx: Integer;
begin
z:=0;
iz:=65536;
if x2<>x1 then t:=65536 div (x2-x1) else t:=0;
if y2<>y1 then t2:=65536 div (y2-y1) else t2:=0;
dx:=x2-x1;
for yc:=y1 to y2-1 do
begin
xx:=((nw*iz+se*z)shr 16);
p:=xx shl 16;
p2:=(((ne*iz+sw*z)shr 16)-xx)*t;
pc:=@Bmp.Pixels8[yc,x1];
for xc:=0 to dx-1 do
begin
Inc(p,p2);
pc^:=p shr 16;
Inc(pc);
end;
Inc(z,t2);
Dec(iz,t2);
end;
end;

procedure GradientFill24(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:TFColor);
var
pc: PFColor;
xc,yc,t,t2,z,iz,rp,
rp2,gp,gp2,bp,bp2,dx,xx: Integer;
begin
z:=0;
iz:=65536;
if x2<>x1 then t:=65536 div (x2-x1) else t:=0;
if y2<>y1 then t2:=65536 div (y2-y1) else t2:=0;
dx:=x2-x1;
for yc:=y1 to y2-1 do
begin
xx:=((nw.r*iz+se.r*z)shr 16);
rp:=xx shl 16;
rp2:=(((ne.r*iz+sw.r*z)shr 16)-xx)*t;
xx:=((nw.g*iz+se.g*z)shr 16);
gp:=xx shl 16;
gp2:=(((ne.g*iz+sw.g*z)shr 16)-xx)*t;
xx:=((nw.b*iz+se.b*z)shr 16);
bp:=xx shl 16;
bp2:=(((ne.b*iz+sw.b*z)shr 16)-xx)*t;
pc:=@Bmp.Pixels24[yc,x1];
for xc:=0 to dx-1 do
begin
Inc(bp,bp2);
Inc(gp,gp2);
Inc(rp,rp2);
pc.b:=bp shr 16;
pc.g:=gp shr 16;
pc.r:=rp shr 16;
Inc(pc);
end;
Inc(z,t2);
Dec(iz,t2);
end;
end;

procedure GradientFill32(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:TFColor);
var
pc: PFColorA;
xc,yc,t,t2,z,iz,rp,
rp2,gp,gp2,bp,bp2,dx,xx: Integer;
begin
z:=0;
iz:=65536;
if x2<>x1 then t:=65536 div (x2-x1) else t:=0;
if y2<>y1 then t2:=65536 div (y2-y1) else t2:=0;
dx:=x2-x1;
for yc:=y1 to y2-1 do
begin
xx:=((nw.r*iz+se.r*z)shr 16);
rp:=xx shl 16;
rp2:=(((ne.r*iz+sw.r*z)shr 16)-xx)*t;
xx:=((nw.g*iz+se.g*z)shr 16);
gp:=xx shl 16;
gp2:=(((ne.g*iz+sw.g*z)shr 16)-xx)*t;
xx:=((nw.b*iz+se.b*z)shr 16);
bp:=xx shl 16;
bp2:=(((ne.b*iz+sw.b*z)shr 16)-xx)*t;
pc:=@Bmp.Pixels32[yc,x1];
for xc:=0 to dx-1 do
begin
Inc(bp,bp2);
Inc(gp,gp2);
Inc(rp,rp2);
pc.b:=bp shr 16;
pc.g:=gp shr 16;
pc.r:=rp shr 16;
Inc(pc);
end;
Inc(z,t2);
Dec(iz,t2);
end;
end;

procedure GradientFill(Bmp:TFastDIB;x1,y1,x2,y2:Integer;nw,ne,se,sw:TFColor);
begin
case Bmp.Bpp of
8: GradientFill8(Bmp,x1,y1,x2,y2,
ClosestColor(Bmp.Colors,255,nw),
ClosestColor(Bmp.Colors,255,ne),
ClosestColor(Bmp.Colors,255,se),
ClosestColor(Bmp.Colors,255,sw));
24: GradientFill24(Bmp,x1,y1,x2,y2,nw,ne,se,sw);
32: GradientFill32(Bmp,x1,y1,x2,y2,nw,ne,se,sw);
end;
end;

procedure Line8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:Byte);
var
d,ax,ay,sx,sy,dx,dy: Integer;
begin
if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

dx:=x2-x1; ax:=Abs(dx)shl 1; if dx<0 then sx:=-1 else sx:=1;
dy:=y2-y1; ay:=Abs(dy)shl 1; if dy<0 then sy:=-1 else sy:=1;
Bmp.Pixels8[y1,x1]:=c;
if ax>ay then
begin
d:=ay-(ax shr 1);
while x1<>x2 do
begin
if d>-1 then
begin
Inc(y1,sy);
Dec(d,ax);
end;
Inc(x1,sx);
Inc(d,ay);
Bmp.Pixels8[y1,x1]:=c;
end;
end else
begin
d:=ax-(ay shr 1);
while y1<>y2 do
begin
if d>=0 then
begin
Inc(x1,sx);
Dec(d,ay);
end;
Inc(y1,sy);
Inc(d,ax);
Bmp.Pixels8[y1,x1]:=c;
end;
end;
end;

procedure Line16(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
d,ax,ay,sx,sy,dx,dy: Integer;
w: Word;
begin
if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

w:=c.b shr Bmp.BShr or c.g shr Bmp.GShr shl Bmp.GShl or c.r shr Bmp.RShr shl Bmp.RShl;
dx:=x2-x1; ax:=Abs(dx)shl 1; if dx<0 then sx:=-1 else sx:=1;
dy:=y2-y1; ay:=Abs(dy)shl 1; if dy<0 then sy:=-1 else sy:=1;
Bmp.Pixels16[y1,x1]:=w;
if ax>ay then
begin
d:=ay-(ax shr 1);
while x1<>x2 do
begin
if d>-1 then
begin
Inc(y1,sy);
Dec(d,ax);
end;
Inc(x1,sx);
Inc(d,ay);
Bmp.Pixels16[y1,x1]:=w;
end;
end else
begin
d:=ax-(ay shr 1);
while y1<>y2 do
begin
if d>=0 then
begin
Inc(x1,sx);
Dec(d,ay);
end;
Inc(y1,sy);
Inc(d,ax);
Bmp.Pixels16[y1,x1]:=w;
end;
end;
end;

procedure Line24(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
d,ax,ay,sx,sy,dx,dy: Integer;
begin
if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

dx:=x2-x1; ax:=Abs(dx)shl 1; if dx<0 then sx:=-1 else sx:=1;
dy:=y2-y1; ay:=Abs(dy)shl 1; if dy<0 then sy:=-1 else sy:=1;
Bmp.Pixels24[y1,x1]:=c;
if ax>ay then
begin
d:=ay-(ax shr 1);
while x1<>x2 do
begin
if d>-1 then
begin
Inc(y1,sy);
Dec(d,ax);
end;
Inc(x1,sx);
Inc(d,ay);
Bmp.Pixels24[y1,x1]:=c;
end;
end else
begin
d:=ax-(ay shr 1);
while y1<>y2 do
begin
if d>=0 then
begin
Inc(x1,sx);
Dec(d,ay);
end;
Inc(y1,sy);
Inc(d,ax);
Bmp.Pixels24[y1,x1]:=c;
end;
end;
end;

procedure Line32(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
d,ax,ay,sx,sy,dx,dy: Integer;
begin
if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

dx:=x2-x1; ax:=Abs(dx)shl 1; if dx<0 then sx:=-1 else sx:=1;
dy:=y2-y1; ay:=Abs(dy)shl 1; if dy<0 then sy:=-1 else sy:=1;
Bmp.Pixels32[y1,x1].c:=c;
if ax>ay then
begin
d:=ay-(ax shr 1);
while x1<>x2 do
begin
if d>-1 then
begin
Inc(y1,sy);
Dec(d,ax);
end;
Inc(x1,sx);
Inc(d,ay);
Bmp.Pixels32[y1,x1].c:=c;
end;
end else
begin
d:=ax-(ay shr 1);
while y1<>y2 do
begin
if d>=0 then
begin
Inc(x1,sx);
Dec(d,ay);
end;
Inc(y1,sy);
Inc(d,ax);
Bmp.Pixels32[y1,x1].c:=c;
end;
end;
end;

procedure Line(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
begin
case Bmp.Bpp of
8: Line8(Bmp,x1,y1,x2,y2,ClosestColor(Bmp.Colors,255,c));
16: Line16(Bmp,x1,y1,x2,y2,c);
24: Line24(Bmp,x1,y1,x2,y2,c);
32: Line32(Bmp,x1,y1,x2,y2,c);
end;
end;

procedure SmoothLine8(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:Byte);
var
dx,dy,d,s,ci,ea,ec: Integer;
p: PByte;
begin
if(y1=y2)or(x1=x2)then Line8(Bmp,x1,y1,x2,y2,c) else
begin

if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

if y1>y2 then
begin
d:=y1; y1:=y2; y2:=d;
d:=x1; x1:=x2; x2:=d;
end;
dx:=x2-x1;
dy:=y2-y1;
if dx>-1 then s:=1 else
begin
s:=-1;
dx:=-dx;
end;
ec:=0;

Bmp.Pixels8[y1,x1]:=c;
if dy>dx then
begin
ea:=(dx shl 16)div dy;
while dy>1 do
begin
Dec(dy);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(x1,s);
Inc(y1);
ci:=ec shr 8;
p:=@Bmp.Pixels8[y1,x1];
p^:=(p^-c)*ci shr 8 + c;
p:=@Bmp.Pixels8[y1,x1+s];
p^:=(c-p^)*ci shr 8 + p^;
end;
end else
begin
ea:=(dy shl 16)div dx;
while dx>1 do
begin
Dec(dx);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(y1);
Inc(x1,s);
ci:=ec shr 8;
p:=@Bmp.Pixels8[y1,x1];
p^:=(p^-c)*ci shr 8 + c;
p:=@Bmp.Pixels8[y1+1,x1];
p^:=(c-p^)*ci shr 8 + p^;
end;
end;
Bmp.Pixels8[y2,x2]:=c;
end;
end;

procedure SmoothLine16(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
dx,dy,s,d,ci,ea,ec: Integer;
b,g,r,w: Word;
p: PWord;
begin
w:=c.b shr Bmp.BShr or c.g shr Bmp.GShr shl Bmp.GShl or c.r shr Bmp.RShr shl Bmp.RShl;

if(y1=y2)or(x1=x2)then Line16(Bmp,x1,y1,x2,y2,c) else
begin

if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

if y1>y2 then
begin
d:=y1; y1:=y2; y2:=d;
d:=x1; x1:=x2; x2:=d;
end;
dx:=x2-x1;
dy:=y2-y1;
if dx>-1 then s:=1 else
begin
s:=-1;
dx:=-dx;
end;
ec:=0;

Bmp.Pixels16[y1,x1]:=w;
if dy>dx then
begin
ea:=(dx shl 16)div dy;
while dy>1 do
begin
Dec(dy);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(x1,s);
Inc(y1);
ci:=ec shr 8;

p:=@Bmp.Pixels16[y1,x1];
b:=( Integer((p^ shl Bmp.BShr)and Bmp.BMask) - c.b)*ci shr 8 + c.b;
g:=( Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask) - c.g)*ci shr 8 + c.g;
r:=( Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask) - c.r)*ci shr 8 + c.r;
p^:=b shr Bmp.BShr or g shr Bmp.GShr shl Bmp.GShl or r shr Bmp.RShr shl Bmp.RShl;

p:=@Bmp.Pixels16[y1,x1+s];
b:=( c.b - Integer((p^ shl Bmp.BShr)and Bmp.BMask))*ci shr 8 + Integer((p^ shl Bmp.BShr)and Bmp.BMask);
g:=( c.g - Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask))*ci shr 8 + Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask);
r:=( c.r - Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask))*ci shr 8 + Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask);
p^:=b shr Bmp.BShr or g shr Bmp.GShr shl Bmp.GShl or r shr Bmp.RShr shl Bmp.RShl;

end;
end else
begin
ea:=(dy shl 16)div dx;
while dx>1 do
begin
Dec(dx);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(y1);
Inc(x1,s);
ci:=ec shr 8;

p:=@Bmp.Pixels16[y1,x1];
b:=( Integer((p^ shl Bmp.BShr)and Bmp.BMask) - c.b)*ci shr 8 + c.b;
g:=( Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask) - c.g)*ci shr 8 + c.g;
r:=( Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask) - c.r)*ci shr 8 + c.r;
p^:=b shr Bmp.BShr or g shr Bmp.GShr shl Bmp.GShl or r shr Bmp.RShr shl Bmp.RShl;

p:=@Bmp.Pixels16[y1+1,x1];
b:=( c.b - Integer((p^ shl Bmp.BShr)and Bmp.BMask))*ci shr 8 + Integer((p^ shl Bmp.BShr)and Bmp.BMask);
g:=( c.g - Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask))*ci shr 8 + Integer((p^ shl Bmp.GShr shr Bmp.GShl)and Bmp.GMask);
r:=( c.r - Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask))*ci shr 8 + Integer((p^ shl Bmp.RShr shr Bmp.RShl)and Bmp.RMask);
p^:=b shr Bmp.BShr or g shr Bmp.GShr shl Bmp.GShl or r shr Bmp.RShr shl Bmp.RShl;
end;
end;
Bmp.Pixels16[y2,x2]:=w;
end;
end;

procedure SmoothLine24(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
dx,dy,d,s,ci,ea,ec: Integer;
p: PFColor;
begin
if(y1=y2)or(x1=x2)then Line24(Bmp,x1,y1,x2,y2,c) else
begin

if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

if y1>y2 then
begin
d:=y1; y1:=y2; y2:=d;
d:=x1; x1:=x2; x2:=d;
end;
dx:=x2-x1;
dy:=y2-y1;

if dx>-1 then
s:=1
else
begin
s:=-1;
dx:=-dx;
end;
ec:=0;

Bmp.Pixels24[y1,x1]:=c;
if dy>dx then
begin
ea:=(dx shl 16)div dy;
while dy>1 do
begin
Dec(dy);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(x1,s);
Inc(y1);
ci:=ec shr 8;
p:=@Bmp.Pixels24[y1,x1];
p.b:=(p.b-c.b)*ci shr 8 + c.b;
p.g:=(p.g-c.g)*ci shr 8 + c.g;
p.r:=(p.r-c.r)*ci shr 8 + c.r;
p:=@Bmp.Pixels24[y1,x1+s];
p.b:=(c.b-p.b)*ci shr 8 + p.b;
p.g:=(c.g-p.g)*ci shr 8 + p.g;
p.r:=(c.r-p.r)*ci shr 8 + p.r;
end;
end else
begin
ea:=(dy shl 16)div dx;
while dx>1 do
begin
Dec(dx);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(y1);
Inc(x1,s);
ci:=ec shr 8;
p:=@Bmp.Pixels24[y1,x1];
p.b:=(p.b-c.b)*ci shr 8 + c.b;
p.g:=(p.g-c.g)*ci shr 8 + c.g;
p.r:=(p.r-c.r)*ci shr 8 + c.r;
p:=@Bmp.Pixels24[y1+1,x1];
p.b:=(c.b-p.b)*ci shr 8 + p.b;
p.g:=(c.g-p.g)*ci shr 8 + p.g;
p.r:=(c.r-p.r)*ci shr 8 + p.r;
end;
end;
Bmp.Pixels24[y2,x2]:=c;
end;
end;

procedure SmoothLine32(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
var
dx,dy,d,s,ci,ea,ec: Integer;
p: PFColorA;
begin
if(y1=y2)or(x1=x2)then Line32(Bmp,x1,y1,x2,y2,c) else
begin

if Bmp.Height>0 then
begin
y1:=Bmp.AbsHeight-y1-1;
y2:=Bmp.AbsHeight-y2-1;
end;

if y1>y2 then
begin
d:=y1; y1:=y2; y2:=d;
d:=x1; x1:=x2; x2:=d;
end;
dx:=x2-x1;
dy:=y2-y1;
if dx>-1 then s:=1 else
begin
s:=-1;
dx:=-dx;
end;
ec:=0;

Bmp.Pixels32[y1,x1].c:=c;
if dy>dx then
begin
ea:=(dx shl 16)div dy;
while dy>1 do
begin
Dec(dy);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(x1,s);
Inc(y1);
ci:=ec shr 8;
p:=@Bmp.Pixels32[y1,x1];
p.b:=(p.b-c.b)*ci shr 8 + c.b;
p.g:=(p.g-c.g)*ci shr 8 + c.g;
p.r:=(p.r-c.r)*ci shr 8 + c.r;
p:=@Bmp.Pixels32[y1,x1+s];
p.b:=(c.b-p.b)*ci shr 8 + p.b;
p.g:=(c.g-p.g)*ci shr 8 + p.g;
p.r:=(c.r-p.r)*ci shr 8 + p.r;
end;
end else
begin
ea:=(dy shl 16)div dx;
while dx>1 do
begin
Dec(dx);
d:=ec;
Inc(ec,ea);
ec:=ec and $FFFF;
if ec<=d then Inc(y1);
Inc(x1,s);
ci:=ec shr 8;
p:=@Bmp.Pixels32[y1,x1];
p.b:=(p.b-c.b)*ci shr 8 + c.b;
p.g:=(p.g-c.g)*ci shr 8 + c.g;
p.r:=(p.r-c.r)*ci shr 8 + c.r;
p:=@Bmp.Pixels32[y1+1,x1];
p.b:=(c.b-p.b)*ci shr 8 + p.b;
p.g:=(c.g-p.g)*ci shr 8 + p.g;
p.r:=(c.r-p.r)*ci shr 8 + p.r;
end;
end;
Bmp.Pixels32[y2,x2].c:=c;
end;
end;

procedure SmoothLine(Bmp:TFastDIB;x1,y1,x2,y2:Integer;c:TFColor);
begin
case Bmp.Bpp of
8: SmoothLine8(Bmp,x1,y1,x2,y2,ClosestColor(Bmp.Colors,255,c));
16: SmoothLine16(Bmp,x1,y1,x2,y2,c);
24: SmoothLine24(Bmp,x1,y1,x2,y2,c);
32: SmoothLine32(Bmp,x1,y1,x2,y2,c);
end;
end;

procedure Polyline8(Bmp:TFastDIB;pnts:array of TPoint;c:Byte);
var
n,i: Integer;
begin
n:=High(pnts)+1;
for i:=0 to n-1 do
Line8(Bmp,pnts.x,pnts.y,pnts[(i+1)mod n].x,pnts[(i+1)mod n].y,c);
end;

procedure Polyline(Bmp:TFastDIB;pnts:array of TPoint;c:TFColor);
var
n,i: Integer;
begin
if Bmp.Bpp=8 then Polyline8(Bmp,pnts,ClosestColor(Bmp.Colors,255,c))else
begin
n:=High(pnts)+1;
for i:=0 to n-1 do
Line(Bmp,pnts.x,pnts.y,pnts[(i+1)mod n].x,pnts[(i+1)mod n].y,c);
end;
end;

procedure SmoothPolyline8(Bmp:TFastDIB;pnts:array of TPoint;c:Byte);
var
n,i: Integer;
begin
n:=High(pnts)+1;
for i:=0 to n-1 do
SmoothLine8(Bmp,pnts.x,pnts.y,pnts[(i+1)mod n].x,pnts[(i+1)mod n].y,c);
end;

procedure SmoothPolyline(Bmp:TFastDIB;pnts:array of TPoint;c:TFColor);
var
n,i: Integer;
begin
if Bmp.Bpp=8 then SmoothPolyline8(Bmp,pnts,ClosestColor(Bmp.Colors,255,c))else
begin
n:=High(pnts)+1;
for i:=0 to n-1 do
SmoothLine(Bmp,pnts.x,pnts.y,pnts[(i+1)mod n].x,pnts[(i+1)mod n].y,c);
end;
end;

end.

[]

多人接受答案了。