Delphi 快速大位图创建(无需清除)

xxhby3vn  于 2022-11-04  发布在  其他
关注(0)|答案(3)|浏览(247)

当使用TBitmap Package 器从单元Graphics中创建GDI位图时,我注意到当使用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内存)。使用这些iomages,创建一个空位图需要150ms,覆盖它的内容需要140ms。
有没有一种方法可以初始化一个大小正确的TBitmap,而不初始化像素本身,并留下像素的内存未初始化(如脏)?或者有没有另一种方法来做这样的事情。我知道我们可以在适当的位置对像素进行工作,但这仍然留下了150ms的像素不必要的初始化。

h4cxqtbf

h4cxqtbf1#

在这里您可以做的事情不多-处理巨大的位图速度很慢...但您可以尝试以下操作:
1.在调用SetSize()后设置PixelFormat-这不会避免像素的初始化,但可能会使其更快。
1.我能想到的最快的方法是使用Win32 API函数(thisthis)创建一个DIB,并将该DIB的HBITMAP句柄分配给TBitmap对象的句柄。
1.使用内存Map文件(同样需要调用API,或者有一些第三方库可以为您做到这一点)。

qmelpv7a

qmelpv7a2#

我知道这是很多年前发布的,但是它仍然是相关的,因为最近的 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.

相关问题