我可以通过覆盖GetPixel / SetPixel方法以某种方式“检测”Graphics.TBitmapCanvas，这些方法特定于TBitmap的画布吗？

Question

As we know, working with TBitmap 's pixels ( Bitmap.Canvas.Pixels[X,Y] ) is very slow in the out-of-box VCL. This has been caused by getter and setter of Pixels property inherited from TCanvas , which encapsulates general WinGDI DC object and is not specific to MemDC of bitmap.

For the DIB section-based bitmaps ( bmDIB ) a well-known workaround exists, however I do not see the way to integrate the proper getter/setter in the VCL TBitmap class (besides direct modification of library code, which proven to be real pain in the stern when it comes to compiling against different VCL versions).

Please advise if there is some hackish way to reach TBitmapCanvas class and inject overriden methods into it.

Answer 1

I'm sure it could be done more elegantly, but here's what you ask for implemented using a class helper to crack the private members:

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.

Include this unit in your project and the TBitmap class will be patched so that its GetCanvas method redirects to NewGetCanvas and allows you to implement your own TCanvas subclass.

I don't think the code will work if you are using runtime packages but to sort that out you just need to use more capable hooking code.