//  它的思想是：准备一个长度为4096的数组，代表4096种颜色。
//  对图中的每一个像素，取R，G，B的最高四位，拼成一个12位的整数，
//  对应的数组元素加1。全部统计完后，就得到了这4096种颜色的使用频率。
//  这其中，可能有一些颜色一次也没用到，即对应的数组元素为零
//  （假设不为零的数组元素共有M个）。
  将这些为零的数组元素清除出去，
//  使得前M个元素都不为零。将这M个数按从大到小的顺序排列，这样，
//  前256种颜色就是用的最多的颜色，它们将作为调色板上的256种颜色。
//  对于剩下的M-256种颜色并不是简单的丢弃，而是用前256种颜色中的
//  一种来代替，代替的原则是找有最小平方误差的那个。
  
// 存在的问题： 在该算法中 只取了R、G、B的最高四位，
//              这样剩下的几位被舍去，会使图像亮度降低。
//          当也可以取全R、G、B的八位，那样效率太低。
//    我们可以加上一个小于16的随机数来补偿。
  
unit CUnit2;
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         // 初始化ColorCount数组
  begin
    ClrCount[i]。
  Color := i;
    ClrCount[i]。Times := 0;
  end;
  with BitMap do
    for i := 0 to ( Height - 1 ) do
    begin
      Ptr := ScanLine[i];
      for j := 0 to (Width - 1) do
      begin //取 R、G、B三种颜色的前4位组成12位，共4096种颜色
        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
// 清除使用次数为 0 的颜色数据,返回值为当前图像中颜色的种类
function Delzero(Var ClrCount : array of LColor): Integer;
var i,CIndex : Integer;
begin
  CIndex := 0;
  for i := 0 to 4096 do
  begin
    if (ClrCount[i]。
  Times <> 0) then
    begin
      ClrCount[CIndex] := ClrCount[i];
      ClrCount[i]。Times := 0;
      Inc(CIndex);
    end;
  end;
  Result := CIndex;
end;//function Delzero
// 快速排序， 将各种颜色 按使用的频率排序(Hight -- Low )
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  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;
// 构建调色表
function BuildColorTable(var ClrCount : array of LColor; 
     var Pal :PLogPalette):HPalette;
var i  : Integer;
begin
   lVersion:=$300;
   lNumEntries:=256;
  for i := 0 to 255 do
  begin
     lPalEntry[i]。
  peRed := ((ClrCount[i]。Color and $0F00) shr 4) + 7;
     lPalEntry[i]。peGreen := (ClrCount[i]。Color and $0F0) + 7;
     lPalEntry[i]。
  peBlue := ((ClrCount[i]。Color and $00F) shl 4) + 7;
     lPalEntry[i]。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[i] := 0;
  for i := 0 to 255 do
    ColorTable[ClrCount[i]。
  Color] := i;
  for i := 256 to ClrNumber do
  begin
    Error := 10000;
    CIndex := 0;
    C := ClrCount[i]。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[i]。
  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[i];
      DPtr := ScanLine[i];
      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。
  
/////////////////////////////
在主程序中调用
uses CUnit2;
。。。
procedure TForm1。Button1Click(Sender: TObject);
begin
    if OpenDialog1。
  Execute then
       Image1。Picture。LoadFromFile(OpenDialog1。FileName);
end;
procedure TForm1。Button2Click(Sender: TObject);
var Bmp : TBitMap;
begin
    Bmp := TBitMap。
  Create;
//    Bmp。Assign(Image1。Picture。Bitmap);
    Convert(Image1。Picture。Bitmap,Bmp);
    PaintBox1。Canvas。Draw(0,0,Bmp);
    Bmp。
  Free;
end;
。