把真彩位图存为16色位图的问题(200分)

我使用以下代码进行转换，但是出现颜色极度失真，请问如何能够优化呢？

Bmp.PixelFormat := pf4bit；

这里有个用抖动算法写的24bit到256色得例子（忘了哪位大侠得杰作！）
unit Unit2;
interface
uses
Windows, Graphics;
type
PRGBColor = ^TRGBColor;
TRGBColor = record
B, G, R: Byte;
end;
PByte = ^Byte;
LColor = record
Color, Times: Integer;
end;

procedure Convert(SBitmap: TBitMap; var DBitMap: TBitMap);

implementation

var
ColorCount: array[0..4096] of LColor;
ColorTable: array[0..4096] of Byte;
procedure CountColor(BitMap: TBitMap; var ClrCount: array of LColor);
var
Ptr: PRGBColor;
i, j: Integer;
CIndex: Integer;
begin
for i := 0 to 4096 do
begin
ClrCount.Color := i;
ClrCount.Times := 0;
end;

with BitMap do
for i := 0 to (Height - 1) do
begin
Ptr := ScanLine;
for j := 0 to (Width - 1) do
begin
CIndex := (Ptr.R and $0F0) shl 4;
CIndex := CIndex + (Ptr.G and $0F0);
CIndex := CIndex + ((Ptr.B and $0F0) shr 4);
Inc(ClrCount[CIndex].Times, 1);
Inc(Ptr);
end;
end;
end; //procedure CountColor
function Delzero(var ClrCount: array of LColor): Integer;
var i, CIndex: Integer;
begin
CIndex := 0;
for i := 0 to 4096 do
begin
if (ClrCount.Times <> 0) then
begin
ClrCount[CIndex] := ClrCount;
ClrCount.Times := 0;
Inc(CIndex);
end;
end;
Result := CIndex;
end; //function Delzero

procedure Sort(var A: array of LColor; Top: Integer);

procedure QuickSort(var A: array of LColor; iLo, iHi: Integer);
var
Lo, Hi, Mid: Integer;
Temp: LColor;
begin
Lo := iLo;
Hi := iHi;
Mid := A[(Lo + Hi) div 2].Times;
repeat
while A[Lo].Times > Mid do Inc(Lo);
while A[Hi].Times < Mid do Dec(Hi);
if Lo <= Hi then
begin
Temp := A[Lo];
A[Lo] := A[Hi];
A[Hi] := Temp;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(A, iLo, Hi);
if Lo < iHi then QuickSort(A, Lo, iHi);
end;

begin
QuickSort(A, Low(A), Top);
end;

// &amp;sup1;&amp;sup1;&amp;frac12;¨&amp;micro;÷&amp;Eacute;&amp;laquo;±í

function BuildColorTable(var ClrCount: array of LColor;
var Pal: PLogPalette): HPalette;
var i: Integer;
begin
Pal.palVersion := $300;
Pal.palNumEntries := 256;
for i := 0 to 255 do
begin
Pal.palPalEntry.peRed := ((ClrCount.Color and $0F00) shr 4) + 7;
Pal.palPalEntry.peGreen := (ClrCount.Color and $0F0) + 7;
Pal.palPalEntry.peBlue := ((ClrCount.Color and $00F) shl 4) + 7;
pal.palPalEntry.peFlags := 0;
end;
Result := CreatePalette(Pal^);
end;

procedure AdjustColor(ClrNumber: Integer; ClrCount: array of LColor);
var i, C, Error, m: Integer;
CIndex: Byte;
begin
// for i := 0 to 4096 do ColorTable := 0;
for i := 0 to 255 do
ColorTable[ClrCount.Color] := i;

for i := 256 to ClrNumber do
begin
Error := 10000;
CIndex := 0;
C := ClrCount.Color;
for m := 0 to 255 do
if abs(ClrCount[m].Color - C) < Error then
begin
Error := abs(ClrCount[m].Color - C);
CIndex := m;
end;
ColorTable[ClrCount.Color] := CIndex;
end;
end; //procedure AdjustColor

procedure Convert(SBitmap: TBitMap; var DBitMap: TBitMap);
var
Pal: PLogPalette;
i, j, t, ColorNumber: integer;
SPtr: PRGBColor;
DPtr: PByte;
begin
if (SBitMap.Empty) then
Exit;

CountColor(SBitMap, ColorCount);
ColorNumber := DelZero(ColorCount);
Sort(ColorCount, ColorNumber);
AdjustColor(ColorNumber, ColorCount);

with DBitMap do
begin
PixelFormat := pf8bit;
SBitMap.PixelFormat := pf24bit;
Width := SBitMap.Width;
Height := SBitMap.Height;

GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
BuildColorTable(ColorCount, Pal);
Palette := BuildColorTable(ColorCount, Pal); // Set DBitMap.Palette
FreeMem(pal);

for i := 0 to (Height - 1) do
begin
SPtr := SBitMap.ScanLine;
DPtr := ScanLine;
for j := 0 to (Width - 1) do
begin
t := (SPtr.R and $0F0) shl 4;
t := t + (SPtr.G and $0F0);
t := t + ((SPtr.B and $0F0) shr 4);
DPtr^ := ColorTable[t];
Inc(SPtr);
Inc(DPtr);
end;
end;

end;
end; //procedure Convert

end.

找到了，这里有讨论:http://www.delphibbs.com/delphibbs/dispq.asp?lid=715571

接受答案了.