Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

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

https://delphiworld.narod.ru/

DelphiWorld 6.0