Permalink
Cannot retrieve contributors at this time
unit SynFPCMetaFile; | |
{$ifndef FPC} | |
unit for FPC under Windows only ! | |
not needed for Delphi / VCL | |
{$endif} | |
{$mode objfpc}{$H+} | |
interface | |
uses | |
Windows, | |
Classes, | |
SysUtils, | |
Graphics; | |
type | |
TMetafile = class; | |
{ TMetafileCanvas } | |
TMetafileCanvas = class(TCanvas) | |
private | |
FMetafile: TMetafile; | |
public | |
constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC); | |
constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC; | |
const CreatedBy, Description: string); | |
destructor Destroy; override; | |
end; | |
{ TMetafile } | |
TMetafile = class(TGraphic) | |
private | |
FImageHandle: HENHMETAFILE; | |
FImageMMWidth: Integer; // are in 0.01 mm logical pixels | |
FImageMMHeight: Integer; // are in 0.01 mm logical pixels | |
FImagePxWidth: Integer; // in device pixels | |
FImagePxHeight: Integer; // in device pixels | |
procedure DeleteImage; | |
function GetAuthor: String; | |
function GetDescription: String; | |
function GetEmpty: Boolean; override; | |
function GetHandle: HENHMETAFILE; | |
function GetMMHeight: Integer; | |
function GetMMWidth: Integer; | |
procedure SetHandle(Value: HENHMETAFILE); | |
procedure SetMMHeight(Value: Integer); | |
procedure SetMMWidth(Value: Integer); | |
protected | |
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; | |
function GetHeight: Integer; override; | |
function GetWidth: Integer; override; | |
procedure SetHeight(Value: Integer); override; | |
procedure SetWidth(Value: Integer); override; | |
function GetTransparent: Boolean; override; | |
procedure SetTransparent(Value: Boolean); override; | |
public | |
constructor Create; override; | |
destructor Destroy; override; | |
procedure Assign(Source: TPersistent); override; | |
procedure Clear; | |
procedure LoadFromFile(const Filename: String); override; | |
procedure LoadFromStream(Stream: TStream); override; | |
procedure SaveToFile(const Filename: String); override; | |
procedure SaveToStream(Stream: TStream); override; | |
function ReleaseHandle: HENHMETAFILE; | |
property Handle: HENHMETAFILE read GetHandle write SetHandle; | |
property Empty: boolean read GetEmpty; | |
property CreatedBy: String read GetAuthor; | |
property Description: String read GetDescription; | |
property MMWidth: Integer read GetMMWidth write SetMMWidth; | |
property MMHeight: Integer read GetMMHeight write SetMMHeight; | |
end; | |
const | |
EMR_HEADER = 1; | |
EMR_POLYBEZIER = 2; | |
EMR_POLYGON = 3; | |
EMR_POLYLINE = 4; | |
EMR_SETWINDOWEXTEX = 9; | |
EMR_SETWINDOWORGEX = 10; | |
EMR_SETVIEWPORTEXTEX = 11; | |
EMR_SETVIEWPORTORGEX = 12; | |
EMR_SETBKMODE = 18; | |
EMR_SETTEXTALIGN = 22; | |
EMR_SETTEXTCOLOR = 24; | |
EMR_SETBKCOLOR = 25; | |
EMR_OFFSETCLIPRGN = 26; | |
EMR_MOVETOEX = 27; | |
EMR_EXCLUDECLIPRECT = 29; | |
EMR_INTERSECTCLIPRECT = 30; | |
EMR_SAVEDC = 33; | |
EMR_RESTOREDC = 34; | |
EMR_SETWORLDTRANSFORM = 35; | |
EMR_SELECTOBJECT = 37; | |
EMR_CREATEPEN = 38; | |
EMR_CREATEBRUSHINDIRECT = 39; | |
EMR_DELETEOBJECT = 40; | |
EMR_ELLIPSE = 42; | |
EMR_RECTANGLE = 43; | |
EMR_ROUNDRECT = 44; | |
EMR_LINETO = 54; | |
EMR_SELECTCLIPPATH = 67; | |
EMR_EXTSELECTCLIPRGN = 75; | |
EMR_BITBLT = 76; | |
EMR_STRETCHBLT = 77; | |
EMR_STRETCHDIBITS = 81; | |
EMR_EXTCREATEFONTINDIRECTW = 82; | |
EMR_EXTTEXTOUTW = 84; | |
EMR_POLYBEZIER16 = 85; | |
EMR_POLYGON16 = 86; | |
EMR_POLYLINE16 = 87; | |
implementation | |
{ TMetafile } | |
procedure TMetafile.DeleteImage; | |
begin | |
if FImageHandle <> 0 then | |
DeleteEnhMetafile(FImageHandle); | |
FImageHandle := 0; | |
end; | |
function TMetafile.GetAuthor: String; | |
var | |
NC: Integer; | |
begin | |
Result := ''; | |
if FImageHandle = 0 then Exit; | |
NC := GetEnhMetafileDescription(FImageHandle, 0, nil); | |
if NC <= 0 then Exit | |
else begin | |
SetLength(Result, NC); | |
GetEnhMetafileDescription(FImageHandle, NC, PChar(Result)); | |
SetLength(Result, StrLen(PChar(Result)) ); | |
end; | |
end; | |
function TMetafile.GetDescription: String; | |
var | |
NC: Integer; | |
begin | |
Result := ''; | |
if FImageHandle = 0 then Exit; | |
NC := GetEnhMetafileDescription(FImageHandle, 0, nil); | |
if NC <= 0 then Exit | |
else begin | |
SetLength(Result, NC); | |
GetEnhMetafileDescription(FImageHandle, NC, PChar(Result)); | |
Delete(Result, 1, StrLen(PChar(Result))+1); | |
SetLength(Result, StrLen(PChar(Result))); | |
end; | |
end; | |
function TMetafile.GetEmpty: Boolean; | |
begin | |
Result := (FImageHandle = 0); | |
end; | |
function TMetafile.GetHandle: HENHMETAFILE; | |
begin | |
Result := FImageHandle | |
end; | |
function TMetafile.GetMMHeight: Integer; | |
begin | |
Result := FImageMMHeight; | |
end; | |
function TMetafile.GetMMWidth: Integer; | |
begin | |
Result := FImageMMWidth; | |
end; | |
procedure TMetafile.SetHandle(Value: HENHMETAFILE); | |
var | |
EnhHeader: TEnhMetaHeader; | |
begin | |
if (Value <> 0) and (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then | |
raise EInvalidImage.Create('Invalid Metafile');; | |
if FImageHandle <> 0 then DeleteImage; | |
FImageHandle := Value; | |
FImagePxWidth := 0; | |
FImagePxHeight := 0; | |
FImageMMWidth := EnhHeader.rclFrame.Right - EnhHeader.rclFrame.Left; | |
FImageMMHeight := EnhHeader.rclFrame.Bottom - EnhHeader.rclFrame.Top; | |
end; | |
procedure TMetafile.SetMMHeight(Value: Integer); | |
begin | |
FImagePxHeight := 0; | |
if FImageMMHeight <> Value then FImageMMHeight := Value; | |
end; | |
procedure TMetafile.SetMMWidth(Value: Integer); | |
begin | |
FImagePxWidth := 0; | |
if FImageMMWidth <> Value then FImageMMWidth := Value; | |
end; | |
procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect); | |
var | |
RT: TRect; | |
begin | |
if FImageHandle = 0 then Exit; | |
RT := Rect; | |
PlayEnhMetaFile(ACanvas.Handle, FImageHandle, RT); | |
end; | |
function TMetafile.GetHeight: Integer; | |
var | |
EMFHeader: TEnhMetaHeader; | |
begin | |
if FImageHandle = 0 then | |
Result := FImagePxHeight | |
else begin // convert 0.01mm units to device pixels | |
GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader); | |
Result := MulDiv(FImageMMHeight, // metafile height in 0.01mm | |
EMFHeader.szlDevice.cy, // device height in pixels | |
EMFHeader.szlMillimeters.cy*100); // device height in mm | |
end | |
end; | |
function TMetafile.GetWidth: Integer; | |
var | |
EMFHeader: TEnhMetaHeader; | |
begin | |
if FImageHandle = 0 then | |
Result := FImagePxWidth | |
else begin // convert 0.01mm units to device pixels | |
GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader); | |
Result := MulDiv(FImageMMWidth, // metafile width in 0.01mm | |
EMFHeader.szlDevice.cx, // device width in pixels | |
EMFHeader.szlMillimeters.cx*100); // device width in 0.01mm | |
end | |
end; | |
procedure TMetafile.SetHeight(Value: Integer); | |
var | |
EMFHeader: TEnhMetaHeader; | |
begin | |
if FImageHandle = 0 then | |
FImagePxHeight := Value | |
else begin // convert device pixels to 0.01mm units | |
GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader); | |
MMHeight := MulDiv(Value, // metafile height in pixels | |
EMFHeader.szlMillimeters.cy*100, // device height in 0.01mm | |
EMFHeader.szlDevice.cy); // device height in pixels | |
end | |
end; | |
procedure TMetafile.SetWidth(Value: Integer); | |
var | |
EMFHeader: TEnhMetaHeader; | |
begin | |
if FImageHandle = 0 then | |
FImagePxWidth := Value | |
else begin // convert device pixels to 0.01mm units | |
GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader); | |
MMWidth := MulDiv(Value, // metafile width in pixels | |
EMFHeader.szlMillimeters.cx*100, // device width in mm | |
EMFHeader.szlDevice.cx); // device width in pixels | |
end | |
end; | |
constructor TMetafile.Create; | |
begin | |
inherited Create; | |
FImageHandle := 0; | |
end; | |
destructor TMetafile.Destroy; | |
begin | |
DeleteImage; | |
inherited Destroy; | |
end; | |
procedure TMetafile.Assign(Source: TPersistent); | |
begin | |
if (Source = nil) or (Source is TMetafile) then begin | |
if FImageHandle <> 0 then DeleteImage; | |
if Assigned(Source) then begin | |
FImageHandle := TMetafile(Source).Handle; | |
FImageMMWidth := TMetafile(Source).MMWidth; | |
FImageMMHeight := TMetafile(Source).MMHeight; | |
FImagePxWidth := TMetafile(Source).Width; | |
FImagePxHeight := TMetafile(Source).Height; | |
end | |
end | |
else | |
inherited Assign(Source); | |
end; | |
procedure TMetafile.Clear; | |
begin | |
DeleteImage; | |
end; | |
procedure TMetafile.LoadFromFile(const Filename: String); | |
begin | |
raise EComponentError.Create('Not Implemented'); | |
end; | |
procedure TMetafile.SaveToFile(const Filename: String); | |
begin | |
raise EComponentError.Create('Not Implemented'); | |
end; | |
procedure TMetafile.LoadFromStream(Stream: TStream); | |
begin | |
raise EComponentError.Create('Not Implemented'); | |
end; | |
procedure TMetafile.SaveToStream(Stream: TStream); | |
begin | |
raise EComponentError.Create('Not Implemented'); | |
end; | |
function TMetafile.ReleaseHandle: HENHMETAFILE; | |
begin | |
DeleteImage; | |
Result := FImageHandle; | |
FImageHandle := 0; | |
end; | |
function TMetafile.GetTransparent: Boolean; | |
begin // not implemented | |
result:=false; | |
end; | |
procedure TMetafile.SetTransparent(Value: Boolean); | |
begin // not implemented | |
end; | |
{ TMetafileCanvas } | |
constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC); | |
begin | |
CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy, | |
AMetafile.Description); | |
end; | |
constructor TMetafileCanvas.CreateWithComment(AMetafile: TMetafile; | |
ReferenceDevice: HDC; const CreatedBy, Description: String); | |
var | |
RefDC: HDC; | |
R: TRect; | |
Temp: HDC; | |
P: PChar; | |
begin | |
inherited Create; | |
FMetafile := AMetafile; | |
if ReferenceDevice = 0 then RefDC := GetDC(0) | |
else RefDC := ReferenceDevice; | |
try | |
if FMetafile.MMWidth = 0 then begin | |
if FMetafile.Width = 0 then //if no width get RefDC height | |
FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100 | |
else FMetafile.MMWidth := MulDiv(FMetafile.Width, //else convert | |
GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES)); | |
end; | |
if FMetafile.MMHeight = 0 then begin | |
if FMetafile.Height = 0 then //if no height get RefDC height | |
FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100 | |
else FMetafile.MMHeight := MulDiv(FMetafile.Height, //else convert | |
GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES)); | |
end; | |
R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight); | |
//lpDescription stores both author and description | |
if (Length(CreatedBy) > 0) or (Length(Description) > 0) then | |
P := PChar(CreatedBy+#0+Description+#0#0) | |
else | |
P := nil; | |
Temp := CreateEnhMetafile(RefDC, nil, @R, P); | |
if Temp = 0 then raise EOutOfResources.Create('Out of Resources');; | |
Handle := Temp; | |
finally | |
if ReferenceDevice = 0 then ReleaseDC(0, RefDC); | |
end; | |
end; | |
destructor TMetafileCanvas.Destroy; | |
begin | |
FMetafile.Handle := CloseEnhMetafile(Handle); | |
inherited Destroy; | |
end; | |
end. | |