vpdfwmf.pas

生成PDF文档的控件

        RotAngle := CurrentFont.lfEscapement * Pi / 1800;
        if WYScal = 0 then
        begin
          X := X - WXScal * cos(RotAngle);
          Y := Y + WXScal * sin(RotAngle);
        end
        else
        begin
          TXLen := sqrt(sqr(WXScal) + sqr(WYScal));
          X := X - TXLen * cos(RotAngle - ArcSin(WYScal / TXLen));
          Y := Y + TXLen * sin(RotAngle - ArcSin(WYScal / TXLen));
        end;
        Y := ScaleY(Y, true);
        X := ScaleX(X, true);
      end;
    end;
    if Data^.emr.iType = EMR_EXTTEXTOUTW then
    begin
      FPage.UnicodeTextOut(X, Y, CurrentFont.lfEscapement / 10, @KGlyphs[0], TextLen);
    end
    else
    begin
{$IFNDEF BCB}
      FPage.TextOut(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ELSE}
      FPage.PrintText(X, Y, CurrentFont.lfEscapement / 10, TextStr);
{$ENDIF}
    end;
  end;
  if not PathContinue then
  begin
    if (Data^.emrtext.fOptions and ETO_Clipped <> 0) then
    begin
      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;
  end;
end;

procedure TVPDFWmf.VEMRALPHABLEND(Data: PEMRAlphaBlend);
var
  I: Integer;
  BMSrc: TBitmap;
  BMTemp: TBitmap;
  BMBits: Pointer;
  HImgLib: THandle;
  BMInfo: PBitmapInfo;
  AlphaComplete: Boolean;
  BlendStruc: _BLENDFUNCTION;

  BlendFnc: function(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest, nHeightDest: Integer;
                 hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc: Integer;
                 blendFunction: TBlendFunction): BOOL; stdcall;
begin
  BMInfo := Displace(Data, Data^.offBmiSrc);
  BMBits := Displace(Data, Data^.offBitsSrc);
  I := 0;
  if (Data^.cySrc > 0) and (Data^.cxSrc > 0) then
  begin
    BMTemp := TBitmap.Create;
    try
      BMTemp.Width := Data^.cxSrc;
      BMTemp.Height := Data^.cySrc;
      StretchDIBits(BMTemp.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height, Data^.xSrc,
        Data^.ySrc, BMTemp.Width, BMTemp.Height, BMBits, BMInfo^, Data^.iUsageSrc, SRCCOPY);
      AlphaComplete := False;
      HImgLib := LoadLibrary('msimg32.dll');
      if HImgLib <> 0 then
      begin
        @BlendFnc := GetProcAddress(HImgLib, 'AlphaBlend');
        if Assigned(@BlendFnc) then
        begin
          AlphaComplete := True;
          BMSrc := TBitmap.Create;
          try
            BMSrc.Width := BMTemp.Width;
            BMSrc.Height := BMTemp.Height;
            Move(Data^.dwRop, BlendStruc, sizeof(BlendStruc));
            BlendFnc(BMSrc.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height,
              BMTemp.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height, BlendStruc);
            if BMSrc.PixelFormat = pf1bit then
              I := FPage.FParent.AddImage(BMSrc, icCCITT42)
            else
              I := FPage.FParent.AddImage(BMSrc, icFlate);
          finally
            BMSrc.Free;
          end;
        end;
      end;
      if (not (AlphaComplete)) then
      begin
        if BMTemp.PixelFormat = pf1bit then I := FPage.FParent.AddImage(BMTemp, icCCITT42)
        else I := FPage.FParent.AddImage(BMTemp, icFlate);
      end;
      FPage.ShowImage(I, ScaleX(Data^.rclBounds.Left, False),
        ScaleY(Data^.rclBounds.Top, False),
        ScaleX(Data^.rclBounds.Right - Data^.rclBounds.Left, False),
        ScaleY(Data^.rclBounds.Bottom - Data^.rclBounds.Top, False), 0);
    finally
      BMTemp.Free;
    end;
  end
  else
  begin
    if (data^.cxDest = 0) or (data^.cyDest = 0) then
      FPage.NewPath
    else
    begin
      FPage.MFRectangle(ScaleX(data^.xDest), ScaleY(Data^.yDest),
        ScaleX(data^.xDest + Data^.cxDest), ScaleY(Data^.yDest + Data^.cyDest));
      FPage.Fill;
    end;
  end;
end;

procedure TVPDFWmf.VEMRBITBLT(Data: PEMRBitBlt);
var
  I: Integer;
  TextPres: Boolean;
  SourBM: TBitmap;
  BMBits: Pointer;
  BMInfo: PBitmapInfo;
  BMRow: Cardinal;
begin
  BMRow := Data^.dwRop;
  if not ((BMRow = SRCCOPY) or (BMRow = BLACKNESS) or (BMRow = DSTINVERT) or
     (BMRow = MERGECOPY) or (BMRow = MERGEPAINT) or (BMRow = NOTSRCCOPY) or
     (BMRow = NOTSRCERASE) or (BMRow = PATCOPY) or (BMRow = PATINVERT) or
     (BMRow = PATPAINT) or (BMRow = SRCAND) or (BMRow = SRCERASE) or
     (BMRow = SRCINVERT) or (BMRow = SRCPAINT) or (BMRow = WHITENESS)) then Exit;
  if TextContinue then
  begin
    TextContinue := False;
    TextPres := True;
  end
  else TextPres := False;
  if (Data^.cbBmiSrc = 0) or (Data^.cbBitsSrc = 0) then
  begin
    if (data^.cxDest = 0) or (data^.cyDest = 0) then FPage.NewPath
    else
    begin
      SetBrushColor(not MadeClip);
      FPage.MFRectangle(ScaleX(data^.xDest), ScaleY(Data^.yDest),
        ScaleX(data^.xDest + Data^.cxDest), ScaleY(Data^.yDest + Data^.cyDest));
      FPage.Fill;
    end;
  end
  else
  begin
    BMInfo := Displace(Data, Data^.offBmiSrc);
    BMBits := Displace(Data, Data^.offBitsSrc);
    SourBM := TBitmap.Create;
    try
      SourBM.Width := Data^.cxDest;
      SourBM.Height := Data^.cyDest;
      StretchDIBits(SourBM.Canvas.Handle, 0, 0, SourBM.Width, SourBM.Height, Data^.xSrc,
        Data^.ySrc, SourBM.Width, SourBM.Height, BMBits, BMInfo^, Data^.iUsageSrc, Data^.dwRop);
      if SourBM.PixelFormat = pf1bit then I := FPage.FParent.AddImage(SourBM, icCCITT42)
      else I := FPage.FParent.AddImage(SourBM, icFlate);
      FPage.ShowImage(I, ScaleX(Data^.rclBounds.Left, False),
        ScaleY(Data^.rclBounds.Top, False),
        ScaleX(Data^.rclBounds.Right - Data^.rclBounds.Left, False),
        ScaleY(Data^.rclBounds.Bottom - Data^.rclBounds.Top, False), 0);
    finally
      SourBM.Free;
    end;
  end;
  if TextPres then TextContinue := True;
end;

procedure TVPDFWmf.VEMRCREATEBRUSHINDIRECT(Data: PEMRCreateBrushIndirect);
begin
  if Data^.ihBrush >= GDIObjectsCount then Exit;
  if GDIObjects[Data^.ihBrush] <> $FFFFFFFF then
    DeleteObject(GDIObjects[Data^.ihBrush]);
  if Data^.lb.lbStyle = BS_SOLID then
    GDIObjects[Data^.ihBrush] := CreateSolidBrush(Data^.lb.lbColor)
  else GDIObjects[Data^.ihBrush] := CreateBrushIndirect(Data^.lb);
end;

procedure TVPDFWmf.VEMREXTCREATEFONTINDIRECTW(Data: PEMRExtCreateFontIndirect);
var
  LogFont: TLogFontA;
begin
  if Data^.ihFont >= GDIObjectsCount then Exit;
  if GDIObjects[Data^.ihFont] <> $FFFFFFFF then DeleteObject(GDIObjects[Data^.ihFont]);
  GDIObjects[Data^.ihFont] := CreateFontIndirectW(Data^.elfw.elfLogFont);
  if GDIObjects[Data^.ihFont] = 0 then
  begin
    Move(data^.elfw.elfLogFont, LogFont, SizeOf(LogFont));
    WideCharToMultiByte(CP_ACP, 0, Data^.elfw.elfLogFont.lfFaceName,
      LF_FACESIZE, LogFont.lfFaceName, LF_FACESIZE, nil, nil);
    GDIObjects[Data^.ihFont] := CreateFontIndirectA(LogFont);
  end;
end;

procedure TVPDFWmf.VEMRCREATEPEN(Data: PEMRCreatePen);
begin
  if Data^.ihPen >= GDIObjectsCount then Exit;
  if GDIObjects[Data^.ihPen] <> $FFFFFFFF then
    DeleteObject(GDIObjects[Data^.ihPen]);
  GDIObjects[Data^.ihPen] := CreatePen(Data^.lopn.lopnStyle,
    Data^.lopn.lopnWidth.x, Data^.lopn.lopnColor);
end;

procedure TVPDFWmf.VEMRDELETEOBJECT(Data: PEMRDeleteObject);
begin
  if Data^.ihObject >= GDIObjectsCount then Exit;
  DeleteObject(GDIObjects[data^.ihObject]);
  GDIObjects[data^.ihObject] := $FFFFFFFF;
end;

procedure TVPDFWmf.VEMREXTCREATEPEN(Data: PEMRExtCreatePen);
begin
  if Data^.ihPen >= GDIObjectsCount then Exit;
  if GDIObjects[Data^.ihPen] <> $FFFFFFFF then
    DeleteObject(GDIObjects[Data^.ihPen]);
  GDIObjects[Data^.ihPen] := CreatePen(Data^.elp.elpPenStyle and
    PS_STYLE_MASK, Data^.elp.elpWidth, Data^.elp.elpColor);
end;

procedure TVPDFWmf.VEMRINTERSECTCLIPRECT(Data: PEMRIntersectClipRect);
begin
  if IsCliped then
  begin
    FPage.GStateRestore;
    MadeClip := True;
    SetPenColor;
    SetBrushColor(False);
    FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
  end;
  FPage.GStateSave;
  IsCliped := True;
  FPage.NewPath;
  FPage.MFRectangle(ScaleX(Data^.rclClip.Left), ScaleY(Data^.rclClip.Top),
    ScaleX(Data^.rclClip.Right), ScaleY(Data^.rclClip.Bottom));
  InterSectClipRect := True;
  ClipRect.Left := ScaleX(Data^.rclClip.Left);
  ClipRect.Top := ScaleY(Data^.rclClip.Top);
  ClipRect.Right := ScaleX(Data^.rclClip.Right);
  ClipRect.Bottom := ScaleY(Data^.rclClip.Bottom);
  FPage.Clip;
  FPage.NewPath;
end;

procedure TVPDFWmf.VEMRRESTOREDC(Data: PEMRRestoreDC);
var
  I: DWORD;
  DCPen: TLogPen;
  TmpObj: HGDIOBJ;
  TmpForm: TXForm;
  BlockSize: TSize;
  BlockBuff: TPoint;
  DCBrush: TLogBrush;
  DCFont: TLogFont;
begin
  RestoreDC(DContext, Data^.iRelative);
  if WTransform then
  begin
    GetWorldTransform(DContext, TmpForm);
    XOffset := TmpForm.eDx * PosiX;
    YOffset := TmpForm.eDy * PosiY;
    ZScaleX := TmpForm.eM11;
    ZScaleY := TmpForm.eM22;
  end
  else
  begin
    if Data^.iRelative < 0 then
      if DCBufferLen + Data^.iRelative >= 0 then
      begin
        lpXForm := DCBuffer[DCBufferLen + Data^.iRelative];
        ZScaleX := lpXForm.eM11;
        ZScaleY := lpXForm.eM22;
        XOffset := lpXForm.eDx * PosiX;
        YOffset := lpXForm.eDy * PosiY;
        DCBufferLen := DCBufferLen + Data^.iRelative;
        SetLength(DCBuffer, DCBufferLen);
      end
      else DCBuffer := nil
    else if DCBufferLen > Data^.iRelative then
    begin
      lpXForm := DCBuffer[Data^.iRelative - 1];
      ZScaleX := lpXForm.eM11;
      ZScaleY := lpXForm.eM22;
      XOffset := lpXForm.eDx * PosiX;
      YOffset := lpXForm.eDy * PosiY;
      DCBufferLen := Data^.iRelative - 1;
      SetLength(DCBuffer, DCBufferLen);
    end;
  end;
  ProjectMode := GetMapMode(DContext);
  BKMode := not (GetBkMode(DContext) = TRANSPARENT);
  TextColor := GetTextColor(DContext);
  if TextContinue then SetFontColor;
  BKColor := GetBkColor(DContext);
  PolyFIllMode := (GetPolyFillMode(DContext) = ALTERNATE);
  GetViewportExtEx(DContext, BlockSize);
  ViewportExtEx := BlockSize.cx;
  ViewportExtEy := BlockSize.cy;
  GetWindowExtEx(DContext, BlockSize);
  WinExtEx := BlockSize.cx;
  WinExtEy := BlockSize.cy;
  GetViewportOrgEx(DContext, BlockBuff);
  ViewportOrgEx := BlockBuff.x;
  ViewportOrgEy := BlockBuff.y;
  GetWindowOrgEx(DContext, BlockBuff);
  WinOrgEx := BlockBuff.x;
  WinOrgEy := BlockBuff.y;
  if IsCliped then
  begin
    IsCliped := False;
    MadeClip := True;
    if TextContinue then
    begin
      FPage.GStateRestore;
    end
    else FPage.GStateRestore;
  end;
  TmpObj := GetCurrentObject(DContext, OBJ_PEN);
  GetObject(TmpObj, SizeOf(DCPen), @DCPen);
  if DCPen.lopnColor <> CurrentPen.lopnColor then
  begin
    CurrentPen.lopnColor := DCPen.lopnColor;
    SetPenColor;
  end;
  if DCPen.lopnStyle <> CurrentPen.lopnStyle then
  begin
    CurrentPen.lopnStyle := DCPen.lopnStyle;
    case CurrentPen.lopnStyle of
      ps_Solid, ps_InsideFrame: FPage.NoDash;
      ps_Dash: FPage.SetDash([8, 8], 0);
      ps_Dot: FPage.SetDash([2, 2], 0);
      ps_DashDot: FPage.SetDash([8, 2, 2, 2], 0);
      ps_DashDotDot: FPage.SetDash([8, 2, 2, 2, 2, 2], 0);
    end;
  end;
  if DCPen.lopnWidth.x * ZScaleX * ZoomX <> CurrentPen.lopnWidth then
  begin
    if DCPen.lopnWidth.x = 0 then CurrentPen.lopnWidth := ZoomX * ZScaleX
    else CurrentPen.lopnWidth := DCPen.lopnWidth.x * ZScaleX * ZoomX;
    FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
  end;
  TmpObj := GetCurrentObject(DContext, OBJ_BRUSH);
  GetObject(TmpObj, SizeOf(DCBrush), @DCBrush);
  if DCBrush.lbColor <> CurrentBrush.lbColor then
  begin
    CurrentBrush.lbColor := DCBrush.lbColor;
    if not TextContinue then SetBrushColor;
  end;
  if DCBrush.lbStyle = 1 then IsNullBrush := True;
  TmpObj := GetCurrentObject(DContext, OBJ_FONT);
  GetObject(TmpObj, SizeOf(DCFont), @DCFont);
  if (CurrentFont.lfFaceName <> DCFont.lfFaceName) or
     (CurrentFont.lfWeight <> DCFont.lfWeight) or
     (CurrentFont.lfItalic <> DCFont.lfItalic) or
    (CurrentFont.lfUnderline <> DCFont.lfUnderline) or
    (CurrentFont.lfStrikeOut <> DCFont.lfStrikeOut) or
    (CurrentFont.lfCharSet <> DCFont.lfCharSet) or
    (CurrentFont.lfHeight <> DCFont.lfHeight) then
  begin
    Move(DCFont, CurrentFont, SizeOf(CurrentFont));
    MadeClip := True;
  end;
  I := GetTextAlign(DContext);
  case I and (TA_LEFT or ta_Right or ta_center) of
    ta_left: HorMode := vhjLeft;
    ta_right: HorMode := vhjRight;
    ta_center: HorMode := vhjCenter;
  end;
  case I and (TA_Top or ta_BaseLine or ta_Bottom) of
    TA_Top: VertMode := vvjUp;
    ta_Bottom: VertMode := vvjDown;
    TA_BASELINE: VertMode := vvjCenter;
  end;
  UpdatePos := (I and TA_UPDATECP = TA_UPDATECP);
end;

procedure TVPDFWmf.VEMRROUNDRECT(Data: PEMRRoundRect);
begin
  FPage.RoundRect(Round(ScaleX(Data^.rclBox.Left)),
    Round(ScaleY(Data^.rclBox.Top)),
    Round(ScaleX(Data^.rclBox.Right)), Round(ScaleY(Data^.rclBox.Bottom)),
    Round(ScaleX(Data^.szlCorner.cx)), Round(ScaleY(Data^.szlCorner.cy)));
  if not PathContinue then
    if (CurrentPen.lopnWidth <> 0) and (CurrentPen.lopnStyle <> ps_null) then
      if not IsNullBrush then FPage.FillAndStroke
      else FPage.Stroke
    else if not IsNullBrush then FPage.Fill