我可以以某种方式"instrument" Graphics.TBitmapCanvas，使用覆盖的GetPixel/SetPixel方法，这些方法特定于TBitmap的画布？

Question

我们知道，在开箱后的VCL中处理TBitmap的像素(Bitmap.Canvas.Pixels[X,Y])是非常慢的。这是由于Pixels属性的getter和setter继承自TCanvas，封装了一般的WinGDI DC对象，而不是针对位图的MemDC。

对于DIB基于节的位图(bmDIB)，存在一个众所周知的解决方案，但是我没有看到在VCL TBitmap类中集成适当的getter/setter的方法(除了直接修改库代码，当涉及到编译不同的VCL版本时，这被证明是真正的痛苦)。

请告知是否有一些hack的方法可以到达TBitmapCanvas类并将覆盖的方法注入其中

Answer 1

我相信它可以做得更优雅，但这里是您要求实现的使用类帮助器来破解私有成员:

unit BitmapCanvasCracker;
interface
uses
  SysUtils, Windows, Graphics;
implementation
procedure Fail;
begin
  raise EAssertionFailed.Create('Fixup failed.');
end;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
  OldProtect: DWORD;
begin
  if not VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then begin
    Fail;
  end;
  Move(NewCode, Address^, Size);
  FlushInstructionCache(GetCurrentProcess, nil, 0);
  if not VirtualProtect(Address, Size, OldProtect, @OldProtect) then begin
    Fail;
  end;
end;
type
  PInstruction = ^TInstruction;
  TInstruction = packed record
    Opcode: Byte;
    Offset: Integer;
  end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
  NewCode: TInstruction;
begin
  NewCode.Opcode := $E9;//jump relative
  NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
  PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
type
  TBitmapCanvas = class(TCanvas)
    // you need to implement this class
  end;
type
  TBitmapHelper = class helper for TBitmap
    function NewGetCanvas: TCanvas;
    class procedure Patch;
  end;
function TBitmapHelper.NewGetCanvas: TCanvas;
begin
  if Self.FCanvas = nil then
  begin
    Self.HandleNeeded;
    if Self.FCanvas = nil then
    begin
      Self.FCanvas := TBitmapCanvas.Create;
      Self.FCanvas.OnChange := Self.Changed;
      Self.FCanvas.OnChanging := Self.Changing;
    end;
  end;
  Result := Self.FCanvas;
end;
class procedure TBitmapHelper.Patch;
begin
  RedirectProcedure(@TBitmap.GetCanvas, @TBitmap.NewGetCanvas);
end;
initialization
  TBitmap.Patch;
end.

将此单元包含在您的项目中，TBitmap类将被修补，以便其GetCanvas方法重定向到NewGetCanvas，并允许您实现自己的TCanvas子类。

我不认为代码将工作，如果你使用运行时包，但要解决这个问题，你只需要使用更强大的挂钩代码。