vpdfwmf.pas

生成PDF文档的控件

{*******************************************************}
{                                                       }
{       This unit is part of the VISPDF VCL library.    }
{       Written by R.Husske - ALL RIGHTS RESERVED.      }
{                                                       }
{       Copyright (C) 2000-2009, www.vispdf.com         }
{                                                       }
{       e-mail: [e-mail]                      }
{       http://www.vispdf.com                           }
{                                                       }
{*******************************************************}

unit VPDFWmf;

interface
uses Windows, Classes, Sysutils, Graphics, VPDFDoc, VPDFFonts, VPDFData,
  VPDFTypes, Math;

{$I VisPDFLib.inc }

type
  TSmallPolyLine = array[0..$FFFFF] of TSmallPoint;
  PSmallPolyLine = ^TSmallPolyLine;
  TPolyLine = array[0..$FFFFF] of TPoint;
  PPolyLine = ^TPolyLine;

  TVPDFWmf = class
  private
    DContext: HDC;
    MetaHandle: THandle;
    FPage: TVPDFPage;
    Meta: TMetafile;
    MetaCanvas: TMetafileCanvas;
    IsCounterClockwise: Boolean;
    ProjectMode: Integer;
    FontScale: Single;
    PosiX: Single;
    PosiY: Single;
    MadeClip: Boolean;
    CurrentVal: TPoint;
    IsNullBrush: Boolean;
    InterSectClipRect: Boolean;
    FTextContinue: Boolean;
    PolyFIllMode: Boolean;
    BLMode: Integer;
    BKMode: Boolean;
    BKColor: Cardinal;
    TextColor: Cardinal;
    VertMode: TVPDFVerticalJust;
    HorMode: TVPDFHorizJust;
    UpdatePos: Boolean;
    IsCliped: Boolean;
    CurrentPen: TVPDFPen;
    CurrentBrush: TLogBrush;
    CurrentFont: TLogFont;
    CurrentFill: Cardinal;
    ClipRect: TVPDFRectangle;
    lpXForm: TXForm;
    WTransform: Boolean;
    DCBuffer: array of TXForm;
    DCBufferLen: Integer;
    XOffset, YOffset: Single;
    ZScaleX, ZScaleY: Single;
    WTypeFont: Boolean;
    GDIObjects: array of HGDIOBJ;
    GDIObjectsCount: DWORD;
    FPathContinue: Boolean;
    WinOrgEx, WinExtEx, WinOrgEy, WinExtEy: Integer;
    ViewportOrgEx, ViewportExtEx, ViewportOrgEy, ViewportExtEy: Integer;
    procedure ExecuteRecord(Data: PEnhMetaRecord);
    procedure VEMRMOVETOEX(Data: PEMRLineTo);
    procedure VEMRLINETO(Data: PEMRLineTo);
    procedure VEMRENDPATH;
    procedure VEMRFILLPATH;
    procedure VEMRBEGINPATH;
    procedure VEMRCLOSEFIGURE;
    procedure VEMRSTROKEANDFILLPATH;
    procedure VEMRSTROKEPATH;
    procedure VEMRSELECTCLIPPATH;
    procedure VEMRABORTPATH;
    procedure VEMRFILLRGN(Data: PEMRFillRgn);
    procedure VEMRSETTEXTCOLOR(Data: PEMRSetTextColor);
    procedure VEMRSETTEXTALIGN(Data: PEMRSelectClipPath);
    procedure VEMRPOLYBEZIER(Data: PEMRPolyline);
    procedure VEMRPOLYBEZIERTO16(Data: PEMRPolyline16);
    procedure VEMRPOLYBEZIER16(Data: PEMRPolyline16);
    procedure VEMRPOLYBEZIERTO(Data: PEMRPolyline);
    procedure VEMRPOLYLINE(Data: PEMRPolyline);
    procedure VEMRPOLYLINETO(Data: PEMRPolyline);
    procedure VEMRPOLYLINE16(Data: PEMRPolyline16);
    procedure VEMRPOLYLINETO16(Data: PEMRPolyline16);
    procedure VEMRPOLYPOLYLINE(Data: PEMRPolyPolyline);
    procedure VEMRPOLYPOLYLINE16(Data: PEMRPolyPolyline16);
    procedure VEMRPOLYGON(Data: PEMRPolyline);
    procedure VEMRPOLYGON16(Data: PEMRPolyline16);
    procedure VEMRPOLYPOLYGON(Data: PEMRPolyPolyline);
    procedure VEMRPOLYPOLYGON16(Data: PEMRPolyPolyline16);
    procedure VEMRPOLYDRAW(Data: PEMRPolyDraw);
    procedure VEMRPOLYDRAW16(Data: PEMRPolyDraw16);
    procedure VEMRANGLEARC(Data: PEMRAngleArc);
    procedure VEMRELLIPSE(Data: PEMREllipse);
    procedure VEMRRECTANGLE(Data: PEMREllipse);
    procedure VEMRROUNDRECT(Data: PEMRRoundRect);
    procedure VEMRARC(Data: PEMRArc);
    procedure VEMRARCTO(Data: PEMRArc);
    procedure VEMRCHORD(Data: PEMRChord);
    procedure VEMRPIE(Data: PEMRPie);
    procedure VEMREXTTEXTOUT(Data: PEMRExtTextOut);
    procedure VEMRSMALLTEXTOUT(Data: PEMRSMALLTEXTOUTA);
    procedure VEMRALPHABLEND(Data: PEMRAlphaBlend);
    procedure VEMRSETBKMODE(Data: PEMRSelectclippath);
    procedure VEMRSETBKCOLOR(Data: PEMRSetTextColor);
    procedure VEMRSETPOLYFILLMODE(Data: PEMRSelectclippath);
    procedure VEMREXTSELECTCLIPRGN(Data: PEMRExtSelectClipRgn);
    procedure VEMRINTERSECTCLIPRECT(Data: PEMRIntersectClipRect);
    procedure VEMRSETSTRETCHBLTMODE(Data: PEMRSetStretchBltMode);
    procedure VEMRCREATEPEN(Data: PEMRCreatePen);
    procedure VEMREXTCREATEPEN(Data: PEMRExtCreatePen);
    procedure VEMRCREATEBRUSHINDIRECT(Data: PEMRCreateBrushIndirect);
    procedure VEMREXTCREATEFONTINDIRECTW(Data: PEMRExtCreateFontIndirect);
    procedure VEMRSETPIXELV(Data: PEMRSetPixelV);
    procedure VEMRSETMAPMODE(Data: PEMRSetMapMode);
    procedure VEMRSETWINDOWEXTEX(Data: PEMRSetViewportExtEx);
    procedure VEMRSETWINDOWORGEX(Data: PEMRSetViewportOrgEx);
    procedure VEMRSETVIEWPORTEXTEX(Data: PEMRSetViewportExtEx);
    procedure VEMRSETVIEWPORTORGEX(Data: PEMRSetViewportOrgEx);
    procedure VEMRSAVEDC;
    procedure VEMRRESTOREDC(Data: PEMRRestoreDC);
    procedure VEMRSETWORLDTRANSFORM(Data: PEMRSetWorldTransform);
    procedure VEMRMODIFYWORLDTRANSFORM(Data: PEMRModifyWorldTransform);
    procedure VEMRSELECTOBJECT(Data: PEMRSelectObject);
    procedure VEMRDELETEOBJECT(Data: PEMRDeleteObject);
    procedure VEMRSETARCDIRECTION(Data: PEMRSetArcDirection);
    procedure VEMRSETDIBITSTODEVICE(Data: PEMRSetDIBitsToDevice);
    procedure VEMRSTRETCHDIBITS(Data: PEMRStretchDIBits);
    procedure VEMRBITBLT(Data: PEMRBitBlt);
    procedure VEMRSETSTRETCHBLT(Data: PEMRStretchBlt);
    function Displace(Buffer: Pointer; Offset: Integer): Pointer;
  private
    function ZoomX: Single;
    function ZoomY: Single;
    procedure StrokeOrPath;
    procedure FSOrPath;
    procedure SetPenColor;
    procedure SetFontColor;
    procedure MFSetBKColor;
    procedure ActivateCurrentFont;
    procedure SetBrushColor(IsPath: Boolean = True);
    function ProjectX(Value: Single): Single;
    function ProjectY(Value: Single): Single;
    procedure SetTextContinue(const Value: Boolean);
    procedure SetPathContinue(const Value: Boolean);
    function ScaleX(Value: Single; Proj: Boolean = True): Single;
    function ScaleY(Value: Single; Proj: Boolean = True): Single;
    property PathContinue: Boolean read FPathContinue write SetPathContinue;
    property TextContinue: Boolean read FTextContinue write SetTextContinue;
  public
    constructor Create(ParentPage: TVPDFPage);
    procedure Analyse(MF: TMetafile);
    destructor Destroy; override;
  end;

implementation

{ TVPDFWmf }

procedure TVPDFWmf.VEMRMOVETOEX(Data: PEMRLineTo);
begin
  CurrentVal.x := Data^.ptl.x;
  CurrentVal.y := Data^.ptl.y;
  if PathContinue then
  begin
    if TextContinue then TextContinue := False;
    FPage.MoveTo(ScaleX(CurrentVal.x), ScaleY(CurrentVal.y));
  end;
end;

procedure TVPDFWmf.VEMRLINETO(Data: PEMRLineTo);
begin
  if not PathContinue then
    FPage.MoveTo(ScaleX(CurrentVal.x), ScaleY(CurrentVal.y));
  FPage.LineTo(ScaleX(Data^.ptl.x), ScaleY(Data^.ptl.y));
  CurrentVal := Data^.ptl;
  if not PathContinue then StrokeOrPath;
end;

procedure TVPDFWmf.VEMRBEGINPATH;
begin
  PathContinue := True;
  FPage.NewPath;
  FPage.MoveTo(ScaleX(CurrentVal.x), ScaleY(CurrentVal.y));
end;

procedure TVPDFWmf.VEMRENDPATH;
begin
  PathContinue := False;
end;

constructor TVPDFWmf.Create(ParentPage: TVPDFPage);
begin
  FPage := ParentPage;
  Meta := TMetafile.Create;
  MetaCanvas := TMetafileCanvas.Create(Meta, FPage.FParent.FCHandle);
  PosiX := FPage.FParent.Resolution / GetDeviceCaps(FPage.FParent.FCHandle,
    LOGPIXELSX);
  PosiY := FPage.FParent.Resolution / GetDeviceCaps(FPage.FParent.FCHandle,
    LOGPIXELSY);
end;

destructor TVPDFWmf.Destroy;
begin
  MetaCanvas.Free;
  Meta.Free;
  inherited;
end;

procedure TVPDFWmf.VEMRFILLPATH;
begin
  PathContinue := False;
  if not IsNullBrush then FPage.Fill;
  FPage.NewPath;
end;

procedure TVPDFWmf.VEMRCLOSEFIGURE;
begin
  FPage.ClosePath;
end;

procedure TVPDFWmf.VEMRABORTPATH;
begin
  FPage.NewPath;
  PathContinue := False;
end;

procedure TVPDFWmf.VEMRSTROKEPATH;
begin
  PathContinue := False;
  StrokeOrPath;
  FPage.NewPath;
end;

procedure TVPDFWmf.VEMRSTROKEANDFILLPATH;
begin
  PathContinue := False;
  FSOrPath;
  PathContinue := False;
  FPage.NewPath;
end;

procedure TVPDFWmf.VEMREXTSELECTCLIPRGN(Data: PEMRExtSelectClipRgn);
var
  I: Integer;
  RGNRect: TRect;
  RegData: PRgnData;
  DataBuff: Pointer;
begin
  if IsCliped then
  begin
    IsCliped := False;
    FPage.GStateRestore;
    FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
    SetPenColor;
    SetBrushColor(False);
    MadeClip := True;
  end;
  if Data^.cbRgnData <> 0 then
  begin
    FPage.GStateSave;
    GetMem(DataBuff, Data^.cbRgnData);
    try
      FPage.NewPath;
      IsCliped := True;
      InterSectClipRect := False;
      RegData := DataBuff;
      Move(Data^.RgnData, DataBuff^, data^.cbRgnData);
      for I := 0 to RegData^.rdh.nCount - 1 do
      begin
        Move(RegData^.Buffer[I * SizeOf(TRect)], RGNRect, SizeOf(RGNRect));
        FPage.MFRectangle(ScaleX(RGNRect.Left, False) + 1, ScaleY(RGNRect.Top,
          False) + 1, ScaleX(RGNRect.Right, False), ScaleY(RGNRect.Bottom, False));
      end;
      FPage.Clip;
      FPage.NewPath;
    finally
      FreeMem(DataBuff);
    end;
  end;
end;

procedure TVPDFWmf.VEMRFILLRGN(Data: PEMRFillRgn);
var
  I: Integer;
  RegData: PRgnData;
  DataBuff: Pointer;
  RGNRect: TRect;
begin
  if Data^.cbRgnData <> 0 then
  begin
    GetMem(DataBuff, Data^.cbRgnData);
    try
      FPage.NewPath;
      RegData := DataBuff;
      Move(Data^.RgnData, DataBuff^, data^.cbRgnData);
      for I := 0 to RegData^.rdh.nCount - 1 do
      begin
        Move(RegData^.Buffer[I * SizeOf(TRect)], RGNRect, SizeOf(RGNRect));
        FPage.MFRectangle(ScaleX(RGNRect.Left, False), ScaleY(RGNRect.Top,
          False), ScaleX(RGNRect.Right, False), ScaleY(RGNRect.Bottom, False));
      end;
      if not IsNullBrush then FPage.Fill;
      FPage.NewPath;
    finally
      FreeMem(DataBuff);
    end;
  end;
end;

procedure TVPDFWmf.VEMRSMALLTEXTOUT(Data: PEMRSMALLTEXTOUTA);
var
  X, Y: Extended;
  TextStr: AnsiString;
  RestoreClip: Boolean;
  RegData: PEMR_SMALLTEXTOUTA;
begin
  RestoreClip := False;
  if Data^.nChars = 0 then Exit;
  if (Data^.fuOptions and $100 = 0) then
  begin
    if IsCliped then
    begin
      RestoreClip := True;
      FPage.GStateRestore;
    end;
    RegData := PEMR_SMALLTEXTOUTA(Data);
    FPage.GStateSave;
    FPage.NewPath;
    FPage.MFRectangle(ScaleX(RegData^.rclClip.Left), ScaleY(RegData^.rclClip.Top),
      ScaleX(RegData^.rclClip.Right), ScaleY(RegData^.rclClip.Bottom));
    FPage.Clip;
    FPage.NewPath;
    X := ScaleX(Data^.ptlReference.x);
    Y := ScaleY(Data^.ptlReference.y);
    SetFontColor;
    ActivateCurrentFont;
    if (Data^.fuOptions and $200 <> 0) then
    begin
      SetLength(TextStr, RegData^.nChars);
      Move(RegData^.cString, TextStr[1], RegData^.nChars);
{$IFNDEF BCB}
      FPage.TextOut(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ELSE}
      FPage.PrintText(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ENDIF}
    end
    else
    begin
      FPage.UnicodeTextOut(X, Y, CurrentFont.lfEscapement / 10, @(RegData^.cString), RegData^.nChars);
    end;
    FPage.GStateRestore;
    MadeClip := True;
    if RestoreClip then
      if InterSectClipRect then
      begin
        FPage.GStateSave;
        FPage.MFRectangle(ClipRect.Left, ClipRect.Top, ClipRect.Right, ClipRect.Bottom);
        FPage.Clip;
        FPage.NewPath;
      end
      else
        IsCliped := False;
  end
  else
  begin
    X := ScaleX(Data^.ptlReference.x);
    Y := ScaleY(Data^.ptlReference.y);
    SetFontColor;
    ActivateCurrentFont;
    if (Data^.fuOptions and $200 <> 0) then
    begin
      SetLength(TextStr, data^.nChars);
      Move(Data^.cString, TextStr[1], Data^.nChars);
{$IFNDEF BCB}
      FPage.TextOut(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ELSE}
      FPage.PrintText(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ENDIF}
    end
    else
    begin
      FPage.UnicodeTextOut(X, Y, CurrentFont.lfEscapement / 10, @(Data^.cString), Data^.nChars);
    end;
  end;
end;

procedure TVPDFWmf.VEMRSETTEXTCOLOR(Data: PEMRSetTextColor);
begin
  TextColor := Data^.crColor;
  SetTextColor(DContext, Data^.crColor);