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.
| 
