如何遍历TBitmap所有像素并获取TAlphaColor？解决内存溢出问题

我需要遍历TBitmap的所有像素并将颜色信息显示在TMemo中，搭建的GUI包含加载图像的TImage、触发操作的TButton和显示结果的TMemo。

原尝试的代码触发了内存溢出异常：

Project raised exception class EOutOfMemory with message 'Out of memory'.

原代码如下：

procedure TForm1.Button1Click(Sender: TObject);
var
  BitmapData: TBitmapData;
begin
  Memo1.Lines.Clear;
  var Bitmap := Image1.Bitmap;
  try
    if Bitmap.Map(TMapAccess.ReadWrite, BitmapData) then
    begin
      try
        for var Y := 0 to Bitmap.Height - 1 do
        begin
          for var X := 0 to Bitmap.Width - 1 do
          begin
            var PixelColor := BitmapData.GetPixel(X, Y);
            Memo1.Lines.Add('X: ' + X.ToString + ' | Y: ' + Y.ToString + ' | ' + AlphaColorToString(PixelColor))
          end;
        end;
      finally
        Bitmap.Unmap(BitmapData);
      end;
    end;
  finally
    Bitmap.Free;
  end;
end;

原代码的问题分析 #

• 错误释放Bitmap：Image1.Bitmap是TImage组件管理的对象，手动调用Bitmap.Free会破坏组件内部的资源管理，导致后续异常或内存问题。
• 频繁UI更新导致内存暴涨：循环中每次调用Memo1.Lines.Add都会触发Memo的重绘和多次内存分配，对于稍大的图像（比如1000x1000就有100万行），瞬间会占用大量内存引发溢出。

修正后的代码（两种方案） #

方案1：优化GetPixel方式，批量构建文本

使用TStringBuilder批量拼接所有像素信息，最后一次性写入Memo，减少内存分配和UI操作：

procedure TForm1.Button1Click(Sender: TObject);
var
  BitmapData: TBitmapData;
  SB: TStringBuilder;
  X, Y: Integer;
  PixelColor: TAlphaColor;
begin
  Memo1.Lines.Clear;
  if not Assigned(Image1.Bitmap) then Exit;

  SB := TStringBuilder.Create;
  try
    if Image1.Bitmap.Map(TMapAccess.ReadOnly, BitmapData) then
    begin
      try
        for Y := 0 to Image1.Bitmap.Height - 1 do
        begin
          for X := 0 to Image1.Bitmap.Width - 1 do
          begin
            PixelColor := BitmapData.GetPixel(X, Y);
            SB.AppendFormat('X: %d | Y: %d | %s'#13#10, [X, Y, AlphaColorToString(PixelColor)]);
          end;
        end;
        Memo1.Lines.Text := SB.ToString;
      finally
        Image1.Bitmap.Unmap(BitmapData);
      end;
    end;
  finally
    SB.Free;
  end;
end;

方案2：指针直接访问像素数据（更高性能）

对于大图像，使用指针直接访问内存中的像素数据，效率远高于GetPixel：

procedure TForm1.Button1Click(Sender: TObject);
var
  BitmapData: TBitmapData;
  SB: TStringBuilder;
  X, Y: Integer;
  PixelPtr: PAlphaColor;
  PixelColor: TAlphaColor;
begin
  Memo1.Lines.Clear;
  if not Assigned(Image1.Bitmap) then Exit;

  SB := TStringBuilder.Create;
  try
    Image1.Bitmap.PixelFormat := pf32bit;
    if Image1.Bitmap.Map(TMapAccess.ReadOnly, BitmapData) then
    begin
      try
        for Y := 0 to Image1.Bitmap.Height - 1 do
        begin
          PixelPtr := BitmapData.GetScanline(Y);
          for X := 0 to Image1.Bitmap.Width - 1 do
          begin
            PixelColor := PixelPtr^;
            SB.AppendFormat('X: %d | Y: %d | %s'#13#10, [X, Y, AlphaColorToString(PixelColor)]);
            Inc(PixelPtr);
          end;
        end;
        Memo1.Lines.Text := SB.ToString;
      finally
        Image1.Bitmap.Unmap(BitmapData);
      end;
    end;
  finally
    SB.Free;
  end;
end;

额外注意事项 #

• 如果图像尺寸很大（比如超过1000x1000），即使批量写入，Memo也可能因为内容过多出现性能问题，此时可以考虑只显示部分像素，或者将内容保存到文件。
• 始终使用ReadOnly模式访问BitmapData（如果不需要修改像素），减少资源占用。

内容的提问来源于stack exchange，提问作者Shaun Roselt