Direct2D.Canvas in einer Bitmap speichern

[TiGü]

Da der interne Übersetzungsstand in Delphi von Direct2D auf der Version 1.0 festgefroren ist, muss man sich ein bisschen behelfen, um per Direct2D 1.1 "einfach" an die rohen Bitmapdaten zu kommen.
Der Quelltext unten baut auf diesem DowWiki-Beispiel auf: https://docwiki.embarcadero.com/RADS...as_exclusively
Nach dem Zeichen in der Paint-Routine kann man per Strg + Rechtsklick das aktuelle Bitmap abspeichern. Default-Dateipfad ist 'C:\Temp\BeispielBitmapFuerDelphiPraxis.bmp'.
Die im folgenden Quelltext verwendeten Definitionen stammen vom MfPack (https://github.com/FactoryXCode/MfPa...ctX.D2d1_1.pas).

Delphi-Quellcode:

unit SaveD2DBitmap;

interface

uses
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
    Vcl.Controls, Vcl.Forms, Vcl.Direct2D, Winapi.D2D1, Winapi.DXGI;

type
    TForm2 = class(TForm)
        procedure FormPaint(Sender: TObject);
        procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    private
        FCanvas: TDirect2DCanvas;
    protected
        procedure CreateWnd; override;

        procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
        procedure WMSize(var Message: TWMSize); message WM_SIZE;
    public
        property Canvas: TDirect2DCanvas read FCanvas;
    end;

var
    Form2: TForm2;

implementation

{$R *.dfm}
{ TForm2 }

type
    // This describes how the individual mapping operation should be performed.
    PD2D1_MAP_OPTIONS = ^D2D1_MAP_OPTIONS;
    D2D1_MAP_OPTIONS = DWord;
{$EXTERNALSYM D2D1_MAP_OPTIONS}

const
    // The mapped pointer has undefined behavior.
    D2D1_MAP_OPTIONS_NONE = D2D1_MAP_OPTIONS(0);
{$EXTERNALSYM D2D1_MAP_OPTIONS_NONE}
    // The mapped pointer can be read from.
    D2D1_MAP_OPTIONS_READ = D2D1_MAP_OPTIONS(1);
{$EXTERNALSYM D2D1_MAP_OPTIONS_READ}
    // The mapped pointer can be written to.
    D2D1_MAP_OPTIONS_WRITE = D2D1_MAP_OPTIONS(2);
{$EXTERNALSYM D2D1_MAP_OPTIONS_WRITE}
    // The previous contents of the bitmap are discarded when it is mapped.
    D2D1_MAP_OPTIONS_DISCARD = D2D1_MAP_OPTIONS(4);
{$EXTERNALSYM D2D1_MAP_OPTIONS_DISCARD}
    // D2D1_MAP_OPTIONS_FORCE_DWORD = FORCEDWORD;

type
    // Specifies how the bitmap can be used.
    PD2D1_BITMAP_OPTIONS = ^D2D1_BITMAP_OPTIONS;
    D2D1_BITMAP_OPTIONS = DWord;
{$EXTERNALSYM D2D1_BITMAP_OPTIONS}

const
    // The bitmap is created with default properties.
    D2D1_BITMAP_OPTIONS_NONE = D2D1_BITMAP_OPTIONS($00000000);
    // The bitmap can be specified as a target in ID2D1DeviceContext.SetTarget
    D2D1_BITMAP_OPTIONS_TARGET = D2D1_BITMAP_OPTIONS($00000001);
    // The bitmap cannot be used as an input to DrawBitmap, DrawImage, in a bitmap
    // brush or as an input to an effect.
    D2D1_BITMAP_OPTIONS_CANNOT_DRAW = D2D1_BITMAP_OPTIONS($00000002);
    // The bitmap can be read from the CPU.
    D2D1_BITMAP_OPTIONS_CPU_READ = D2D1_BITMAP_OPTIONS($00000004);
    // The bitmap works with the ID2D1GdiInteropRenderTarget.GetDC API.
    D2D1_BITMAP_OPTIONS_GDI_COMPATIBLE = D2D1_BITMAP_OPTIONS($00000008);
    // D2D1_BITMAP_OPTIONS_FORCE_DWORD = FORCEDWORD;

type
    // Describes mapped memory from the ID2D1Bitmap1.Map API.
    PD2D1_MAPPED_RECT = ^D2D1_MAPPED_RECT;

    D2D1_MAPPED_RECT = record
        pitch: UINT32;
        bits: PByte;
    end;

    ID2D1Bitmap1 = interface(ID2D1Bitmap)
        ['{a898a84c-3873-4588-b08b-ebbf978df041}']

        // Retrieves the color context information associated with the bitmap.
        procedure GetColorContext(out colorContext: IInterface); stdcall;

        // Retrieves the bitmap options used when creating the API.
        function GetOptions(): D2D1_BITMAP_OPTIONS; stdcall;

        // Retrieves the DXGI surface from the corresponding bitmap, if the bitmap was
        // created from a device derived from a D3D device.
        function GetSurface(out dxgiSurface: IDXGISurface): HResult; stdcall;

        // Maps the given bitmap into memory. The bitmap must have been created with the
        // D2D1_BITMAP_OPTIONS_CPU_READ flag.
        function Map(options: D2D1_MAP_OPTIONS; out mappedRect: D2D1_MAPPED_RECT): HResult; stdcall;

        // Unmaps the given bitmap from memory.
        function Unmap(): HResult; stdcall;

    end;

    IID_ID2D1Bitmap1 = ID2D1Bitmap1;

    // Extended bitmap properties.
    PD2D1_BITMAP_PROPERTIES1 = ^D2D1_BITMAP_PROPERTIES1;

    D2D1_BITMAP_PROPERTIES1 = record
        _pixelFormat: D2D1_PIXEL_FORMAT;
        dpiX: Single;
        dpiY: Single;
        // Specifies how the bitmap can be used.
        bitmapOptions: D2D1_BITMAP_OPTIONS;
        colorContext: IInterface;
    end;
{$EXTERNALSYM D2D1_BITMAP_PROPERTIES1}

    // Interface ID2D1DeviceContext
    // ============================
    // The device context represents a set of state and a command buffer that is used
    // to render to a target bitmap.
    //
{$HPPEMIT 'DECLARE_DINTERFACE_TYPE(ID2D1DeviceContext);'}
{$EXTERNALSYM ID2D1DeviceContext}

    ID2D1DeviceContext = interface(ID2D1RenderTarget)
        ['{e8f7fe7a-191c-466d-ad95-975678bda998}']

        // Creates a bitmap with extended bitmap properties, potentially from a block of
        // memory.
        function CreateBitmap(size: D2D1_SIZE_U; sourceData: Pointer; pitch: UINT32; bitmapProperties: PD2D1_BITMAP_PROPERTIES1;
          out bitmap: ID2D1Bitmap1): HResult; stdcall;
    end;

procedure DoSaveAsBitmap(const ARenderTarget: ID2D1RenderTarget; ABitmapFileName: string = '');
var
    HR: HResult;
    DeviceContext: ID2D1DeviceContext;
    CopyBitmap: ID2D1Bitmap1;
    MapOptions: D2D1_MAP_OPTIONS;
    MappedRect: D2D1_MAPPED_RECT;
    SizeU: D2D1_SIZE_U;
    destPoint: D2D1_POINT_2U;
    srcRect: D2D1_RECT_U;
    BitmapProps: D2D1_BITMAP_PROPERTIES1;
    BitmapInfo: TBitmapInfo;
    VCLBitmap: TBitmap;
    NumberOfScanLinesCopied: UINT32;
begin
    if Supports(ARenderTarget, ID2D1DeviceContext, DeviceContext) then
    begin
        DeviceContext.GetPixelFormat(BitmapProps._pixelFormat);
        DeviceContext.GetDpi(BitmapProps.dpiX, BitmapProps.dpiY);
        DeviceContext.GetPixelSize(SizeU);
        BitmapProps.bitmapOptions := D2D1_BITMAP_OPTIONS_CPU_READ or D2D1_BITMAP_OPTIONS_CANNOT_DRAW;

        HR := DeviceContext.CreateBitmap(SizeU, nil, 0, @BitmapProps, CopyBitmap);
        if Succeeded(HR) then
        begin
            srcRect.left := 0;
            srcRect.top := 0;
            srcRect.right := SizeU.Width;
            srcRect.bottom := SizeU.Height;

            destPoint.X := 0;
            destPoint.Y := 0;
            HR := CopyBitmap.CopyFromRenderTarget(destPoint, DeviceContext, srcRect);
            if Succeeded(HR) then
            begin
                MapOptions := D2D1_MAP_OPTIONS_READ;
                HR := CopyBitmap.Map(MapOptions, MappedRect);
                if Succeeded(HR) then
                begin
                    FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);

                    SizeU.Width := MappedRect.pitch div 4;

                    BitmapInfo.bmiHeader.biSize := SizeOf(BitmapInfo.bmiHeader);
                    BitmapInfo.bmiHeader.biHeight := -SizeU.Height;
                    BitmapInfo.bmiHeader.biWidth := SizeU.Width;
                    BitmapInfo.bmiHeader.biPlanes := 1;
                    BitmapInfo.bmiHeader.biBitCount := 32;

                    VCLBitmap := TBitmap.Create(SizeU.Width, SizeU.Height);
                    try
                        VCLBitmap.PixelFormat := TPixelFormat.pf32bit;
                        NumberOfScanLinesCopied := SetDIBits(VCLBitmap.Canvas.Handle, VCLBitmap.Handle, 0, VCLBitmap.Height, MappedRect.bits,
                          BitmapInfo, DIB_RGB_COLORS);

                        if NumberOfScanLinesCopied > 0 then
                        begin
                            if ABitmapFileName = '' then
                            begin
                                ABitmapFilename := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) + 'Test.bmp';
                            end;
                            VCLBitmap.SaveToFile(ABitmapFilename);
                        end
                        else
                            RaiseLastOSError;
                    finally
                        VCLBitmap.Free;
                    end;
                    CopyBitmap.Unmap;
                end;
            end;
        end;
    end;
end;

procedure TForm2.CreateWnd;
begin
    inherited;
    FCanvas := TDirect2DCanvas.Create(Handle);
end;

procedure TForm2.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    if (ssCtrl in Shift) and (Button = TMouseButton.mbRight) then
    begin
        DoSaveAsBitmap(FCanvas.RenderTarget, 'C:\Temp\BeispielBitmapFuerDelphiPraxis.bmp');
    end;
end;

procedure TForm2.FormPaint(Sender: TObject);
var
    LRect: TRect;
begin
    LRect := Self.ClientRect;
    { Drawing goes here }
    Canvas.Brush.Color := clRed;
    Canvas.Pen.Color := clBlue;
    Canvas.Rectangle(10, 10, LRect.Width div 2, LRect.Height div 2);

    Canvas.Pen.Color := clYellow;
    Canvas.DrawLine(D2D1PointF(0, 0), D2D1PointF(LRect.Width, LRect.Height));
end;

procedure TForm2.WMPaint(var Message: TWMPaint);
var
    PaintStruct: TPaintStruct;
begin
    BeginPaint(Handle, PaintStruct);
    try
        FCanvas.BeginDraw;
        try
            Paint;
        finally
            FCanvas.EndDraw;
        end;
    finally
        EndPaint(Handle, PaintStruct);
    end;
end;

procedure TForm2.WMSize(var Message: TWMSize);
var
    ClientSize: TD2D1SizeU;
begin
    if Assigned(FCanvas) then
    begin
        ClientSize := D2D1SizeU(ClientWidth, ClientHeight);
        ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(ClientSize);
    end;

    inherited;
end;

end.