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

Советы » GIF, JPEG, MetaFile » Канва для метафайлов

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

.

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

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com