Delphi World - Канва для метафайлов

Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...

Канва для метафайлов

В: Мне необходимо нарисовать Windows-метафайл. Delphi непосредственно это не поддерживает, поэтому для создания нового метафайла я использую функции Windows API. При создании метафайла мне возвращается его THandle, являющийся дескриптором контекста устройства Windows (DC).

Как мне в Delphi использовать возвращаемый THandle для получения или создания канвы (Canvas) для рисования?

О: несколько дней назад я задавал аналогичный вопрос, но не получил ответа, поэтому пришлось искать решение самому. Вот код (надеюсь это то, что нужно):

unit Metaform;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;

type

  TForm1 = class(TForm)
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    Image1: TImage;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

type

  TMetafileCanvas = class(TCanvas)
  private
    FClipboardHandle: THandle;
    FMetafileHandle: HMetafile;
    FRect: TRect;
  protected
    procedure CreateHandle; override;
    function GetMetafileHandle: HMetafile;
  public
    constructor Create;
    destructor Destroy; override;
    property Rect: TRect read FRect write FRect;
    property MetafileHandle: HMetafile read GetMetafileHandle;
  end;

constructor TMetafileCanvas.Create;
begin

  inherited Create;
  FClipboardHandle := GlobalAlloc(
    GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
end;

destructor TMetafileCanvas.Destroy;
begin

  DeleteMetafile(CloseMetafile(Handle));
  if Bool(FClipboardHandle) then
    GlobalFree(FClipboardHandle);
  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  inherited Destroy;
end;

procedure TMetafileCanvas.CreateHandle;
var

  MetafileDC: HDC;
begin

  { Создаем в памяти DC метафайла }
  MetafileDC := CreateMetaFile(nil);
  if Bool(MetafileDC) then
  begin
    { Совмещаем верхний левый угол отображаемого прямоугольника с левым верхним углом
    контекста устройства. Создаем границу шириной 10 логических единиц вокруг изображения. }
    with FRect do
      SetWindowOrg(MetafileDC, Left - 10, Top - 10);
    { Устанавливаем размер изображения с бордюром, имеющим ширину 10 логических единиц. }
    with FRect do
      SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
    { Задаем корректное содержание данному метафайлу. }
    if Bool(FMetafileHandle) then
    begin
      PlayMetafile(MetafileDC, FMetafileHandle);
    end;
  end;
  Handle := MetafileDC;
end;

function TMetafileCanvas.GetMetafileHandle: HMetafile;
var

  MetafilePict: PMetafilePict;
  IC: HDC;
  ExtRect: TRect;
begin

  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  FMetafileHandle := CloseMetafile(Handle);
  Handle := 0;
  { Подготавливаем метафайл для показа в буфере обмена. }
  MetafilePict := GlobalLock(FClipboardHandle);
  MetafilePict^.mm := mm_AnIsoTropic;
  IC := CreateIC('DISPLAY', nil, nil, nil);
  SetMapMode(IC, mm_HiMetric);
  ExtRect := FRect;
  DPtoLP(IC, ExtRect, 2);
  DeleteDC(IC);
  MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
  MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
  MetafilePict^.HMF := FMetafileHandle;
  GlobalUnlock(FClipboardHandle);
  { Передаем дескриптор в качестве результата выполнения функции. }
  Result := FClipboardHandle;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var

  MetafileCanvas: TMetafileCanvas;
begin

  MetafileCanvas := TMetafileCanvas.Create;
  MetafileCanvas.Rect := Rect(0, 0, 500, 500);
  MetafileCanvas.Ellipse(10, 10, 400, 400);
  Image1.Picture.Metafile.LoadFromClipboardFormat(
    cf_MetafilePict, MetafileCanvas.MetafileHandle, 0);
  MetafileCanvas.Free;
end;

end.