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

В: Мне необходимо нарисовать 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
.

Другое по теме:

• Как работать с GIF файлами
• Получить размер GIF-картинки
• Изменить размер Jpeg и сохранить его в новый файл