Delphi-PRAXiS - Delphi Direct2D.Canvas in einer Bitmap speichern

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.