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.