xtool/contrib/mORMot/SynFPCMetaFile.pas

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.