Delphi fast large bitmap creation (without clearing)

When using the TBitmap wrapper for a GDI bitmap from the unit Graphics I noticed it will always clear out the bitmap (using a PatBlt call) when setting up a bitmap with SetSize( w, h ). When I copy in the bits later on (se开发者_如何学Pythone routine below) it seems ScanLine is the fastest possibility and not 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;

The bitmaps I need to work with are quite large (150MB of RGB memory). With these iomages it takes 150ms to simply create an empty bitmap and a further 140ms to overwrite it's contents.

Is there a way of initializing a TBitmap with the correct size WITHOUT initializing the pixels itself and leaving the memory of the pixels uninitialized (eg dirty)? Or is there another way to do such a thing. I know we could work on the pixels in place but this still leaves the 150ms of unnessesary initializtion of the pixels.

There's not many things you can do here - working with huge bitmaps is slow... but you can try following:

1. Set PixelFormat after calling SetSize() - this won't avoid initialization of pixels but might make it faster.

2. The fastest way I can think of is to use Win32 API functions (this or this) to create a DIB, and the assign HBITMAP handle of that DIB to a Handle of your TBitmap object.

3. Use memory-mapped files (once again requires calling API or alternatively there are some third-party libraries that can do that for you).

I know this was posted many years ago, however it's still relevant as recent Delphi versions behave in the same inefficient manner.

I've created a basic yet functional TBitmap alternative which is very light and efficient. It can be extended in various ways of course to add desired functionality, however it is working and useful as it is. Tested with 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.

That's what I did on a similar problem:

1. Copy the contents of Graphics.pas unit to a new unit called MyGraphics.pas
2. In the new MyGraphics.pas look for the implementation of the function CopyBitmap and comment out the line with: PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);
3. Replace the uses of Graphics to MyGraphics everywhere in your Delphi project.

That's it, create faster empty Bitmaps...