GDI+在Delphi程序的应用 – 真彩色图像转索引图像

最近有几张真彩色图片需要转换为GIF图片，直接用GDI+位图转换存储效果太差，网上搜索半天，也没找到完全合适的，有关Delphi语言和GDI+转换的详细资料更是没发现，只好自己写了几个Delphi类，发表在这里供大家参考。

下面是几个真彩色转索引图像类的完整代码：

type
  TImageData = packed record  
    Width: Integer;           // 像素宽度   
    Height: Integer;          // 像素高度   
    Stride: Integer;          // 扫描宽度   
    LineOffset: Integer;      // 扫描行偏移
    Scan0: Pointer;           // 扫描行首地址   
    Reserved: Integer;        // 保留
  end;   
  PImageData = ^TImageData;

  TIndexTree = class;

  TColorNode = class
  private
    FIsLeaf: Boolean;
    FPixelCount: LongWord;
    FRedSum: LongWord;
    FGreenSum: LongWord;
    FBlueSum: LongWord;
    FChild: array[0..7] of TColorNode;
    FNext: TColorNode;
    FTree: TIndexTree;
  public
    constructor Create(Level: Integer; Tree: TIndexTree);
    destructor Destroy; override;
    procedure AddColor(PColor: PRGBQuad; Level: Integer);
    procedure GetPaletteColors(var Index: Integer);
  end;

  TIndexFormat = (if4bit, if8bit);

  TIndexTree = class
  private
    FColorBits: LongWord;
    FMaxColors: LongWord;
    FLeafCount: LongWord;
    FData: TImageData;
    FColorBackground: TColor;
    FPal: PLogPalette;
    FNodes: array[0..8] of TColorNode;
    function GetFormat: TIndexFormat;
    procedure SetFormat(const Value: TIndexFormat);
    procedure SetColorBackground(const Value: TColor);
  protected
    function CanIndex: Boolean;
    procedure CreateIndexData(var IndexData: TImageData);
    procedure CreatePalette(GDIBitmap: Boolean);
    procedure CopySourceData(Source: TImageData; Source24bit: Boolean);
    function GetImageData(Width, Height, Stride: Integer;
      Scan0: Pointer; Bits: Integer): TImageData;
    function GetIndexData(Scan0: Pointer): TImageData;
    function GetIndexColor(PColor: PRGBQuad): Integer; virtual;
    procedure ReduceTree;
    procedure SetSourceData(Width, Height: Integer);
    procedure Update; virtual;
    property LogPalette: PLogPalette read FPal;
    property LeafCount: LongWord read FLeafCount write FLeafCount;
    property Data: TImageData read FData write FData;
  public
    constructor Create;
    destructor Destroy; override;
    // 32位图像Alpha通道背景颜色，必须在设置图像源之前设置，缺省为白色，
    property ColorBackground: TColor read FColorBackground write SetColorBackground;
    // 索引图格式
    property IndexFormat: TIndexFormat read GetFormat write SetFormat;
  end;

  TBitmapIndexTree = class(TIndexTree)
  private
    procedure SetSource(const Value: TGraphic);
  protected
    function CreateBitmap: TBitmap;
  public
    // 获取按索引图格式建立的索引位图
    function GetIndexBitmap: TBitmap;
    // 获取按索引图格式建立的调色板
    function GetPalette: HPalette;
    // 设置源图像
    property Source: TGraphic write SetSource;
  end;

  TGpBitmapIndexTree = class(TIndexTree)
  private
    FPalette: PColorPalette;
    procedure SetSource(const Value: TGpBitmap);
  protected
    function CreateBitmap: TGpBitmap;
    procedure Update; override;
  public
    destructor Destroy; override;
    // 获取按索引图格式建立的GDI+索引位图
    function GetIndexBitmap: TGpBitmap;
    // 获取按索引图格式建立的GDI+调色板
    function GetPalette: PColorPalette;
    // 设置源图像
    property Source: TGpBitmap write SetSource;
  end;

{ TColorNode }

procedure TColorNode.AddColor(PColor: PRGBQuad; Level: Integer);
const
  mask: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
var
  Index, shift: Integer;
begin
  if FIsLeaf then
  begin
    Inc(FPixelCount);
    Inc(FRedSum, PColor^.rgbRed);
    Inc(FGreenSum, PColor^.rgbGreen);
    Inc(FBlueSum, PColor^.rgbBlue);
  end
  else
  begin
    shift := 7 - Level;
    Index := (((PColor.rgbRed and mask[Level]) shr shift) shl 2) or
             (((PColor.rgbGreen and mask[Level]) shr shift) shl 1) or
             ((PColor.rgbBlue and mask[Level]) shr shift);
    Inc(Level);
    if not Assigned(FChild[Index]) then
      FChild[Index] := TColorNode.Create(Level, FTree);
    FChild[Index].AddColor(PColor, Level);
  end;
end;

constructor TColorNode.Create(Level: Integer; Tree: TIndexTree);
begin
  FTree := Tree;
  FIsLeaf := Level = FTree.FColorBits;
  if FIsLeaf then
    Inc(FTree.FLeafCount)
  else
  begin
    FNext := FTree.FNodes[Level];
    FTree.FNodes[Level] := Self;
  end;
end;

destructor TColorNode.Destroy;
var
  I: Integer;
begin
  for I := 0 to 7 do
    if Assigned(FChild[I]) then
      FChild[I].Free;
end;

procedure TColorNode.GetPaletteColors(var Index: Integer);
var
  I: Integer;
begin
  if FIsLeaf then
  begin
    FTree.FPal^.palPalEntry[Index].peRed := FRedSum div FPixelCount;
    FTree.FPal^.palPalEntry[Index].peGreen := FGreenSum div FPixelCount;
    FTree.FPal^.palPalEntry[Index].peBlue := FBlueSum div FPixelCount;
    FTree.FPal^.palPalEntry[Index].peFlags := 0;
    Inc(Index);
  end
  else
  begin
    for I := 0 to 7 do
      if Assigned(FChild[I]) then
        FChild[I].GetPaletteColors(Index);
  end;
end;

{ TIndexTree }

function TIndexTree.CanIndex: Boolean;
begin
  Result := FData.Scan0 <> nil;
end;

procedure TIndexTree.CopySourceData(Source: TImageData; Source24bit: Boolean);
var
  Color: LongWord;
asm
    push      esi
    push      edi
    push      ebx

    push      ecx
    lea       edi, [eax].TIndexTree.FData
    mov       eax, [eax].TIndexTree.FColorBackground
    bswap     eax
    shr       eax, 8
    or        eax, 0ff000000h
    mov       Color, eax
    mov       ebx, [edx].TImageData.LineOffset
    mov       esi, [edx].TImageData.Scan0    
    mov       ecx, [edi].TImageData.Width
    mov       edx, [edi].TImageData.Height
    mov       edi, [edi].TImageData.Scan0
    cld
    pop       eax
    test      eax, 1
    jnz       @@1
    pxor      mm7, mm7        // mm7 = 00 00 00 00 00 00 00 00
    movd      mm3, Color      // mm3 = 00 00 00 00 Ad Rd Gd Bd
    punpcklbw mm3, mm7        // mm3 = 00 Ad 00 Rd 00 Gd 00 Bd
    movq      mm1, mm3
    psllw     mm1, 8          // mm1 = Ad*256 Rd*256 Gd*256 Bd*256
  @yLoop32:
    push      ecx
  @xLoop32:
    movd      mm0, [esi]      // mm0 = 00 00 00 00 As Rs Gs Bs
    punpcklbw mm0, mm7        // mm0 = 00 As 00 Rs 00 Gs 00 Bs
    movq      mm2, mm0
    punpckhwd mm2, mm2
    punpckhdq mm2, mm2        // mm2 = Alpha Alpha Alpha Alpha
    psubw     mm0, mm3        // mm0 = As-Ad Rs-Rd Gs-Gd Bs-Bd
    pmullw    mm0, mm2        // mm0 = As*Alpha Rs*Alpha Gs*Alpha Bs*Alpha
    paddw     mm0, mm1        // mm0 = 00 An 00 Rn 00 Gn 00 Bn
    psrlw     mm0, 8          // mm0 = An/256 Rn/256 Gn/256 Bn/256
    packuswb  mm0, mm7        // mm0 = 00 00 00 00 An Rn Gn Bn
    movd      [edi], mm0
    add       esi, 4
    add       edi, 4
    loop      @xLoop32
    pop       ecx
    add       esi, ebx
    dec       edx
    jnz       @yLoop32
    emms
    jmp       @@2
  @@1:
  @yLoop:
    push      ecx
  @xLoop:
    movsw
    movsb
    inc       edi
    loop      @xLoop
    pop       ecx
    add       esi, ebx
    dec       edx
    jnz       @yLoop
  @@2:

    pop       ebx
    pop       edi
    pop       esi
end;

constructor TIndexTree.Create;
begin
  IndexFormat := if8bit;
  FColorBackground := clWhite;
end;

procedure TIndexTree.CreateIndexData(var IndexData: TImageData);
var
  P: PRGBQuad;
  Pd: PByte;

  // 设置256色图像像素
  procedure SetPixels8;
  var
    x, y: Integer;
  begin
    for y := 1 to FData.Height do
    begin
      for x := 1 to FData.Width do
      begin
        Pd^ := GetIndexColor(P);
        Inc(P);
        Inc(Pd);
      end;
//      Inc(Integer(P), FData.LineOffset);
      Inc(Integer(Pd), IndexData.LineOffset);
    end;
  end;

  // 设置16色图像像素
  procedure SetPixels4;
  var
    x, y, n: Integer;
  begin
    n := FData.Width shr 1;
    for y := 1 to FData.Height do
    begin
      for x := 1 to n do
      begin
        // 每字节2像素交错存放(首像素高4位，次像素低4位)
        Pd^ := GetIndexColor(P) shl 4;
        Inc(P);
        Pd^ := Pd^ or GetIndexColor(P);
        Inc(P);
        Inc(Pd);
      end;
      if (FData.Width and 1) <> 0 then
      begin
        Pd^ := GetIndexColor(P) shl 4;
        Inc(P);
        Inc(Pd);
      end;
//      Inc(Integer(P), FData.LineOffset);
      Inc(Pd, IndexData.LineOffset);
    end;
  end;

begin
  P := FData.Scan0;
  Pd := IndexData.Scan0;
  if FColorBits = 8 then
    SetPixels8
  else
    SetPixels4;
end;

procedure TIndexTree.CreatePalette(GDIBitmap: Boolean);
var
  Node: TColorNode;
  x, y, Index: Integer;
  P: PRGBQuad;
  Offset: Integer;
begin
  if FPal <> nil then Exit;
  Node := TColorNode.Create(0, Self);
  try
    P := FData.Scan0;
    Offset := FData.LineOffset;
    if GDIBitmap then
    begin
      Inc(LongWord(P), (FData.Height - 1) * FData.Stride);
      Dec(Offset, FData.Stride shl 1);
    end;
    for y := 1 to FData.Height do
    begin
      for x := 1 to FData.Width do
      begin
        Node.AddColor(P, 0);
        while FLeafCount > FMaxColors do
          ReduceTree;
        Inc(P);
      end;
      Inc(Integer(P), Offset);
    end;
    GetMem(FPal, Sizeof(TLogPalette) + (FLeafCount - 1) * Sizeof(TPaletteEntry));
    Index := 0;
    Node.GetPaletteColors(Index);
    FPal^.palVersion := $300;
    FPal^.palNumEntries := FLeafCount;
  finally
    Node.Free;
  end;
end;

destructor TIndexTree.Destroy;
begin
  if FPal <> nil then
    FreeMem(FPal);
  if FData.Scan0 <> nil then
    FreeMem(FData.Scan0);
end;

function TIndexTree.GetFormat: TIndexFormat;
begin
  if FColorBits = 8 then
    Result := if8bit
  else
    Result := if4bit;
end;

function TIndexTree.GetImageData(Width, Height, Stride: Integer;
  Scan0: Pointer; Bits: Integer): TImageData;
begin
  Result.Width := Width;
  Result.Height := Height;
  Result.Scan0 := Scan0;
  Result.Stride := Stride;
  if Result.Stride = 0 then
    Result.Stride := ((Bits * Width + 31) and $ffffffe0) shr 3;
  if Bits = 4 then Inc(Width);
  Result.LineOffset := Result.Stride - ((Width * Bits) shr 3);
end;

function TIndexTree.GetIndexColor(PColor: PRGBQuad): Integer;
var
  Count, Index, Diff: LongWord;
asm
    push    esi
    push    edi
    push    ebx

    mov     ecx, [eax].TIndexTree.FLeafCount
    mov     Count, ecx
    mov     esi, [eax].TIndexTree.FPal
    lea     esi, [esi].TLogPalette.palPalEntry
    movzx   edi, [edx]
    movzx   ecx, [edx + 1]
    movzx   ebx, [edx + 2]
    mov     Diff, 655025
    mov     Index, esi
    push    esi
  @Loop:
    movzx   eax, [esi]
    movzx   edx, [esi + 1]
    sub     eax, ebx
    sub     edx, ecx
    imul    eax, eax
    imul    edx, edx
    add     eax, edx
    movzx   edx, [esi + 2]
    sub     edx, edi
    imul    edx, edx
    add     eax, edx
    test    eax, eax
    jnz     @@4
    mov     Index, esi
    jmp     @@6
  @@4:
    cmp     eax, Diff
    jae     @@5
    mov     Diff, eax
    mov     Index, esi
  @@5:
    add     esi, 4
    dec     Count
    jnz     @Loop
  @@6:
    pop     esi
    mov     eax, Index
    sub     eax, esi
    shr     eax, 2
    
    pop     ebx
    pop     edi
    pop     esi
end;

{
function TIndexTree.GetIndexColor(PColor: PRGBQuad): Integer;
var
  I: Integer;
  Diff, MinDiff: LongWord;
  rv, gv, bv: Integer;
begin
  MinDiff := 655025;
  Result := -1;
  for I := 0 to FPal^.palNumEntries - 1 do
  begin
    rv := PColor^.rgbRed - FPal^.palPalEntry[I].peRed;
    gv := PColor^.rgbGreen - FPal^.palPalEntry[I].peGreen;
    bv := PColor^.rgbBlue - FPal^.palPalEntry[I].peBlue;
    Diff := LongWord(rv * rv + gv * gv + bv * bv);
    if Diff = 0 then
    begin
      Result := I;
      Exit;
    end;
    if Diff < MinDiff then
    begin
      MinDiff := Diff;
      Result := I;
    end;
  end;
end;
}
function TIndexTree.GetIndexData(Scan0: Pointer): TImageData;
begin
  Result := GetImageData(FData.Width, FData.Height, 0, Scan0, FColorBits);
end;

procedure TIndexTree.ReduceTree;
var
  I: Integer;
  Node: TColorNode;
begin
  I := FColorBits - 1;
  while FNodes[I] = nil do Dec(I);
  Node := FNodes[I];
  FNodes[I] := Node.FNext;
  for I := 0 to 7 do
  begin
    if Node.FChild[I] <> nil then
    begin
      Inc(Node.FRedSum, Node.FChild[I].FRedSum);
      Inc(Node.FGreenSum, Node.FChild[I].FGreenSum);
      Inc(Node.FBlueSum, Node.FChild[I].FBlueSum);
      Inc(Node.FPixelCount, Node.FChild[I].FPixelCount);
      FreeAndNil(Node.FChild[I]);
      Dec(FLeafCount);
    end;
  end;
  Inc(FLeafCount);
  Node.FIsLeaf := True;
end;

procedure TIndexTree.SetColorBackground(const Value: TColor);
begin
  if Value < 0 then
    FColorBackground := GetSysColor(Value and $FF)
  else
    FColorBackground := Value;
end;

procedure TIndexTree.SetFormat(const Value: TIndexFormat);
begin
  if IndexFormat <> Value then
  begin
    if Value = if8bit then
      FColorBits := 8
    else
      FColorBits := 4;
    FMaxColors := 1 shl FColorBits;
    Update;
  end;
end;

procedure TIndexTree.SetSourceData(Width, Height: Integer);
begin
  if FData.Scan0 <> nil then
    FreeMem(FData.Scan0);
  FData := GetImageData(Width, Height, 0, nil, 32);
  GetMem(FData.Scan0, FData.Height * FData.Stride);
end;

procedure TIndexTree.Update;
begin
  if FPal <> nil then
  begin
    FreeMem(FPal);
    FPal := nil;
  end;
  FLeafCount := 0;
end;

{ TBitmapIndexTree }

function TBitmapIndexTree.CreateBitmap: TBitmap;
var
  IndexData: TImageData;
  palette: HPalette;
begin
  Result := TBitmap.Create;
  if FColorBits = 8 then
    Result.PixelFormat := pf8bit
  else
    Result.PixelFormat := pf4bit;
  Result.Width := SourceData.Width;
  Result.Height := SourceData.Height;
  Palette := GetPalette;
  Result.Palette := Palette;
  DeleteObject(Palette);
  IndexData := GetIndexData(Result.ScanLine[SourceData.Height - 1]);
  CreateIndexData(IndexData);
end;

function TBitmapIndexTree.GetIndexBitmap: TBitmap;
begin
  if CanIndex then
    Result := CreateBitmap
  else
    Result := nil;
end;

function TBitmapIndexTree.GetPalette: HPalette;
begin
  if CanIndex then
  begin
    CreatePalette(True);
    Result := Windows.CreatePalette(LogPalette^);
  end
  else
    Result := 0;
end;

procedure TBitmapIndexTree.SetSource(const Value: TGraphic);
var
  bmp: TBitmap;
  sData: TImageData;
  Bits: Integer;
begin
  if Assigned(Value) and not Value.Empty then
  begin
    Bmp := TBitmap.Create;
    try
      Bmp.Assign(Value);
      if Bmp.PixelFormat = pf24bit then
        Bits := 24
      else if Bmp.PixelFormat = pf32bit then
        Bits := 32
      else
        raise Exception.Create('Only supports 24 or 32 image sources.');
      sData := GetImageData(Bmp.Width, Bmp.Height, 0, Bmp.ScanLine[Bmp.Height - 1], Bits);
      SetSourceData(sData.Width, sData.Height);
      CopySourceData(sData, Bits = 24);
      Update;
    finally
      Bmp.Free;
    end;
  end;
end;

{ TGpBitmapIndexTree }

function TGpBitmapIndexTree.CreateBitmap: TGpBitmap;
var
  IndexData: TImageData;
  GpData: TBitmapData;
begin
  if FColorBits = 8 then
    Result := TGpBitmap.Create(Data.Width, Data.Height, pf8bppIndexed)
  else
    Result := TGpBitmap.Create(Data.Width, Data.Height, pf4bppIndexed);
  Result.Palette := GetPalette;
  GpData := Result.LockBits(GpRect(0, 0, Data.Width, Data.Height),
    [imRead, imWrite], Result.PixelFormat);
  try
    IndexData := GetIndexData(GpData.Scan0);
    CreateIndexData(IndexData);
  finally
    Result.UnlockBits(GpData);
  end;
end;

destructor TGpBitmapIndexTree.Destroy;
begin
  if FPalette <> nil then
    FreeMem(FPalette);
  inherited;
end;

function TGpBitmapIndexTree.GetIndexBitmap: TGpBitmap;
begin
  if CanIndex then
    Result := CreateBitmap
  else
    Result := nil;
end;

function TGpBitmapIndexTree.GetPalette: PColorPalette;
var
  I: Integer;
begin
  if CanIndex and (FPalette = nil) then
  begin
    CreatePalette(False);
    GetMem(FPalette, Sizeof(TColorPalette) + (LeafCount - 1) * Sizeof(TARGB));
    with LogPalette^ do
    for I := 0 to LeafCount - 1 do
      FPalette^.Entries[I] := (palPalEntry[I].peRed shl 16) or
                              (palPalEntry[I].peGreen shl 8) or
                              palPalEntry[I].peBlue or $FF000000;
    FPalette.Flags := 0;
    FPalette.Count := LeafCount;
  end;
  Result := FPalette;
end;

procedure TGpBitmapIndexTree.SetSource(const Value: TGpBitmap);
var
  GpData: TBitmapData;
  sData: TImageData;
begin
  if Assigned(Value) then
  begin
    if Value.PixelFormat = pf32bppARGB then
    begin
      GpData := Value.LockBits(GpRect(0, 0, Value.Width, Value.Height), [imRead], pf32bppARGB);
      sData := GetImageData(GpData.Width, GpData.Height, GpData.Stride, GpData.Scan0, 32);
      SetSourceData(sData.Width, sData.Height);
      CopySourceData(sData, False);
      Value.UnlockBits(GpData);
    end
    else
    begin
      SetSourceData(Value.Width, Value.Height);
      GpData.Stride := Data.Stride;
      GpData.Scan0 := Data.Scan0;
      GpData := Value.LockBits(GpRect(0, 0, Data.Width, Data.Height),
        [imRead, imUserInputBuf], pf32bppARGB);
      Value.UnlockBits(GpData);
    end;
    Update;
  end;
end;

procedure TGpBitmapIndexTree.Update;
begin
  inherited;
  if FPalette <> nil then
  begin
    FreeMem(FPalette);
    FPalette := nil;
  end;
end;

代码中共定义了四个类：TColorNode是一个八叉树颜色节点类；TIndexTree是图像转换基类，支持真彩色转换256色和16色图像，绝大部分转换工作都写在了这个类中；TBitmapIndexTree是Delphi的TGraphic对象转换类；TGpBitmapIndexTree是GDI+位图转换类。代码没做大的优化，除了一个数据拷贝过程TIndexTree.CopySourceData和像素色彩的调色板匹配方法TIndexTree.GetIndexColor采用了BASM代码，其余都采用纯Delphi代码（TIndexTree.GetIndexColor也有一个被注销的纯Delphi代码，可供参考）。

下面是GDI+32位PNG图像转256色图片例子代码（保存代码没在例子中）：

var
  Bmp, Bmp8: TGpBitmap;
  IndexTree: TGpBitmapIndexTree;
  g: TGpGraphics;
begin
  Bmp := TGpBitmap.Create('d:\xmas_011.png');
  IndexTree := TGpBitmapIndexTree.Create;
  try
    IndexTree.Source := Bmp;
    Bmp8 := IndexTree.GetIndexBitmap;
    g := TGpGraphics.Create(Canvas.Handle);
    try
      g.DrawImage(Bmp, 0, 0);
      g.DrawImage(Bmp8, 0, 200);
    finally
      g.Free;
      Bmp8.Free;
    end;
  finally
    IndexTree.Free;
    Bmp.Free;
  end;
end;

效果图如下，左边是PNG源图，中间是转换后存储的白色背景GIF图片（设置ColorBackground属性可改变背景颜色），右边是没经过转换直接存储的GIF图片：

下面是TJPEGImage对象真彩色转256色图像例子：

var
  JPG: TJPEGImage;
  Bmp8: TBitmap;
  IndexTree: TBitmapIndexTree;
begin
  JPG := TJPEGImage.Create;
  JPG.LoadFromFile('D:\VclLib\GdiplusDemo\Media\20041001.jpg'{'d:\20041001-1.bmp'});
  IndexTree := TBitmapIndexTree.Create;
  try
    Canvas.Draw(0, 0, JPG);
    IndexTree.Source := JPG;
    Bmp8 := IndexTree.GetIndexBitmap;
    try
      Canvas.Draw(0, 200, Bmp8);
    finally
      Bmp8.Free;
    end;
  finally
    IndexTree.Free;
    JPG.Free;
  end;

效果图如下（上边是JPEG源图，下边是转换后的256色GIF图像）：

代码中所用Gdiplus单元下载地址及BUG更正见文章《GDI+ for VCL基础 -- GDI+ 与 VCL》。

建议和指导请来信：[e-mail]