БОЛЬШОЙ FAQ ПО DELPHI



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

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



Видеокурс ВЗЛОМ