Delphi快速大位图创建（无需清除）

Question

当使用 Graphics 单元中的 GDI 位图的 TBitmap 包装器时，我注意到在使用 SetSize( w, h ) 设置位图时，它总是会清除位图（使用 PatBlt 调用）。当我稍后复制这些位时（参见下面的例程），似乎 ScanLine 是最快的可能性，而不是 SetDIBits。

function ToBitmap: TBitmap;
var
    i, N, x: Integer;
    S, D:    PAnsiChar;
begin
  Result := TBitmap.Create();
  Result.PixelFormat := pf32bit;
  Result.SetSize( width, height );
  S := Src;
  D := Result.ScanLine[ 0 ];
  x := Integer( Result.ScanLine[ 1 ] ) - Integer( D );
  N := width * sizeof( longword );
  for i := 0 to height - 1 do begin
    Move( S^, D^, N );
    Inc( S, N );
    Inc( D, x );
  end;
end;

我需要使用的位图非常大（150MB 的 RGB 内存）。使用这些 iimages，只需 150 毫秒即可创建一个空位图，另外还需要 140 毫秒来覆盖其内容。

有没有一种方法可以用正确的大小初始化 TBitmap 而不初始化像素本身并使像素的内存未初始化（例如脏）？或者还有其他方法可以做这样的事情。我知道我们可以就地处理像素，但这仍然会留下 150 毫秒不必要的像素初始化。

Answer 1

我知道这是很多年前发布的，但是它仍然具有相关性，因为最近的 Delphi 版本的行为方式同样低效。

我创建了一个基本但实用的 TBitmap 替代方案，它非常轻量且高效。当然，它可以通过各种方式进行扩展以添加所需的功能，但它确实有效且有用。使用 Delphi 10.4 进行测试。

unit VideoBitmap;

interface
uses Windows, Vcl.Graphics, SysUtils;

type
  TVideoBitmap=class(TGraphic)
  private
    FWidth, FHeight: Integer;
    FDC: HDC;
    FBitmap: HBITMAP;
    FBits: Pointer;

    function GetScanLine(Row: Integer): Pointer;
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetWidth: Integer; override;
    function GetHeight: Integer; override;
  public
    constructor Create(x,y: Integer);
    destructor Destroy; override;

    property ScanLine[Row: Integer]: Pointer read GetScanLine;
  end;

implementation

{ TVideoBitmap }

constructor TVideoBitmap.Create;
var
  BitmapInfo: TBitmapInfo;
begin
  FWidth := x;
  FHeight := y;

  FDC := CreateCompatibleDC(0);
  if FDC = 0 then RaiseLastOSError;

  FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
  with BitmapInfo.bmiHeader do
  begin
    biSize := sizeof (BITMAPINFOHEADER);
    biWidth := x;
    biHeight := y;
    biPlanes := 1;
    biBitCount := 32;
    biCompression := BI_RGB;
  end;

  FBitmap := CreateDIBSection(0, BitmapInfo, 0, FBits, 0, 0);

  if FBitmap = 0 then RaiseLastOSError;
  if FBits = nil then raise Exception.Create('Error getting bits of DIB section');

  SelectObject(FDC, FBitmap);
end;

destructor TVideoBitmap.Destroy;
begin
  if FBitmap <> 0 then
    Win32Check(DeleteObject(FBitmap));

  if FDC <> 0 then
    Win32Check(DeleteDC(FDC));;

  inherited;
end;

procedure TVideoBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  CanvasDC: HDC;
begin
  CanvasDC := ACanvas.Handle;

  SetStretchBltMode(CanvasDC, STRETCH_DELETESCANS);
  SetBrushOrgEx(CanvasDC, 0, 0, nil);
  StretchBlt(CanvasDC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
          FDC, 0, 0, FWidth,
          FHeight, ACanvas.CopyMode);
end;

function TVideoBitmap.GetEmpty: Boolean;
begin
  Result := False;
end;

function TVideoBitmap.GetHeight: Integer;
begin
  Result := FHeight;
end;

function TVideoBitmap.GetScanLine(Row: Integer): Pointer;
begin
  Assert(Row >= 0);
  Assert(Row < FHeight);

  Result := Pointer(IntPtr(FBits) + (FHeight-1-Row)*FWidth*4);
end;

function TVideoBitmap.GetWidth: Integer;
begin
  Result := FWidth;
end;

end.