vpdfwmf.pas

生成PDF文档的控件

    else FPage.NewPath;
end;

procedure TVPDFWmf.VEMRSAVEDC;
begin
  SaveDC(DContext);
  if not WTransform then
  begin
    Inc(DCBufferLen);
    if (DCBufferLen >= 1) then
    begin
      SetLength(DCBuffer, DCBufferLen);
      DCBuffer[DCBufferLen - 1] := lpXForm;
    end;
  end;
end;

procedure TVPDFWmf.VEMRSELECTCLIPPATH;
begin
  if IsCliped then
  begin
    FPage.GStateRestore;
    FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
    SetPenColor;
    SetBrushColor(False);
    MadeClip := True;
  end;
  FPage.GStateSave;
  IsCliped := True;
  FPage.Clip;
  InterSectClipRect := False;
  FPage.NewPath;
  PathContinue := False;
end;

procedure TVPDFWmf.VEMRSELECTOBJECT(Data: PEMRSelectObject);
var
  ObjPen: TLogPen;
  ObjBrush: TLogBrush;
  ObjFont: TLogFont;
  ObjType: DWORD;
begin
  if (Data^.ihObject and $80000000) = 0 then
  begin
    if Data^.ihObject >= GDIObjectsCount then Exit;
    SelectObject(DContext, GDIObjects[Data^.ihObject]);
    ObjType := GetObjectType(GDIObjects[Data^.ihObject]);
    case ObjType of
      OBJ_PEN:
        begin
          GetObject(GDIObjects[Data^.ihObject], SizeOf(ObjPen), @ObjPen);
          if ObjPen.lopnColor <> CurrentPen.lopnColor then
          begin
            CurrentPen.lopnColor := ObjPen.lopnColor;
            SetPenColor;
          end;
          if ObjPen.lopnStyle <> CurrentPen.lopnStyle then
          begin
            CurrentPen.lopnStyle := ObjPen.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 ObjPen.lopnWidth.x * ZScaleX * ZoomX <> CurrentPen.lopnWidth then
          begin
            if ObjPen.lopnWidth.x = 0 then CurrentPen.lopnWidth := ZScaleX * ZoomX
            else CurrentPen.lopnWidth := ObjPen.lopnWidth.x * ZScaleX * ZoomX;
            FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
          end;
        end;
      OBJ_BRUSH:
        begin
          IsNullBrush := False;
          GetObject(GDIObjects[Data^.ihObject], SizeOf(ObjBrush),
            @ObjBrush);
          if ObjBrush.lbColor <> CurrentBrush.lbColor then
          begin
            CurrentBrush.lbColor := ObjBrush.lbColor;
            if not TextContinue then SetBrushColor;
          end;
          if ObjBrush.lbStyle = 1 then IsNullBrush := True;
        end;
      OBJ_FONT:
        begin
          GetObject(GDIObjects[Data^.ihObject], SizeOf(ObjFont),
            @ObjFont);
          if (CurrentFont.lfFaceName <> ObjFont.lfFaceName) or
            (CurrentFont.lfWeight <> ObjFont.lfWeight) or
            (CurrentFont.lfItalic <> ObjFont.lfItalic) or
            (CurrentFont.lfUnderline <> ObjFont.lfUnderline) or
            (CurrentFont.lfStrikeOut <> ObjFont.lfStrikeOut) or
            (CurrentFont.lfCharSet <> ObjFont.lfCharSet) or
            (CurrentFont.lfHeight <> ObjFont.lfHeight) then
          begin
            Move(ObjFont, CurrentFont, SizeOf(CurrentFont));
            MadeClip := True;
          end
          else if (CurrentFont.lfEscapement <> ObjFont.lfEscapement) or
            (CurrentFont.lfOrientation <> ObjFont.lfOrientation) then
            Move(ObjFont, CurrentFont, SizeOf(CurrentFont));
        end;
    end;
  end
  else
  begin
    ObjType := Data^.ihObject and $7FFFFFFF;
    SelectObject(DContext, GetStockObject(ObjType));
    case ObjType of
      WHITE_BRUSH:
        begin
          IsNullBrush := False;
          CurrentBrush.lbColor := clWhite;
          if not TextContinue then SetBrushColor;
        end;
      LTGRAY_BRUSH:
        begin
          IsNullBrush := False;
          CurrentBrush.lbColor := $AAAAAA;
          if not TextContinue then SetBrushColor;
        end;
      GRAY_BRUSH:
        begin
          IsNullBrush := False;
          CurrentBrush.lbColor := $808080;
          if not TextContinue then SetBrushColor;
        end;
      DKGRAY_BRUSH:
        begin
          IsNullBrush := False;
          CurrentBrush.lbColor := $666666;
          if not TextContinue then SetBrushColor;
        end;
      BLACK_BRUSH:
        begin
          IsNullBrush := False;
          CurrentBrush.lbColor := 0;
          if not TextContinue then SetBrushColor;
        end;
      Null_BRUSH:
        begin
          CurrentBrush.lbColor := clWhite;
          IsNullBrush := True;
          if not TextContinue then SetBrushColor;
        end;
      WHITE_PEN:
        begin
          CurrentPen.lopnColor := clWhite;
          FPage.SetRGBStrokeColor(clWhite);
          CurrentPen.lopnWidth := ZScaleX * ZoomX;
          FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
        end;
      BLACK_PEN:
        begin
          CurrentPen.lopnColor := clBlack;
          FPage.SetRGBStrokeColor(clBlack);
          CurrentPen.lopnWidth := ZScaleX * ZoomX;
          FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
        end;
      Null_PEN:
        begin
          CurrentPen.lopnStyle := PS_NULL;
        end;
      OEM_FIXED_FONT, ANSI_FIXED_FONT, ANSI_VAR_FONT, SYSTEM_FONT:
        begin
          CurrentFont.lfFaceName := 'Arial';
          MadeClip := True;
        end;
    end;
  end;
end;

procedure TVPDFWmf.VEMRSETARCDIRECTION(Data: PEMRSetArcDirection);
begin
  IsCounterClockwise := Data^.iArcDirection = AD_COUNTERCLOCKWISE;
end;

procedure TVPDFWmf.VEMRSETBKCOLOR(Data: PEMRSetTextColor);
begin
  BKColor := Data^.crColor;
  SetBkColor(DContext, Data^.crColor);
end;

procedure TVPDFWmf.VEMRSETBKMODE(Data: PEMRSelectclippath);
begin
  BKMode := not (Data^.iMode = TRANSPARENT);
  SetBkMode(DContext, Data^.iMode);
end;

procedure TVPDFWmf.VEMRSETDIBITSTODEVICE(Data: PEMRSetDIBitsToDevice);
var
  I: Integer;
  BMBits: Pointer;
  BMTemp: TBitmap;
  BMInfo: PBitmapInfo;
begin
  BMInfo := Displace(Data, Data^.offBmiSrc);
  BMBits := Displace(Data, Data^.offBitsSrc);
  BMTemp := TBitmap.Create;
  try
    BMTemp.Width := Data^.cxSrc;
    BMTemp.Height := Data^.cySrc;
    SetDIBitsToDevice(BMTemp.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height, Data^.xSrc,
      Data^.ySrc, Data^.iStartScan, Data^.cScans, BMBits, BMInfo^, Data^.iUsageSrc);
    if BMTemp.PixelFormat = pf1bit then I := FPage.FParent.AddImage(BMTemp, icCCITT42)
    else I := FPage.FParent.AddImage(BMTemp, icFlate);
    FPage.ShowImage(I, ScaleX(Data^.rclBounds.Left, false), ScaleY(Data^.rclBounds.Top, False),
      PosiX * ZoomX * ZScaleX * data^.cxSrc, PosiY * ZoomY * ZScaleY * Data^.cySrc, 0);
  finally
    BMTemp.Free;
  end;
end;

procedure TVPDFWmf.VEMRSETPIXELV(Data: PEMRSetPixelV);
begin
  FPage.NewPath;
  if Data^.crColor <> CurrentPen.lopnColor then
    FPage.SetRGBStrokeColor(Data^.crColor);
  if CurrentPen.lopnWidth <> 1 then
    FPage.SetLineWidth(1);
  FPage.MoveTo(ScaleX(Data^.ptlPixel.x), ScaleY(Data^.ptlPixel.y));
  FPage.LineTo(ScaleX(Data^.ptlPixel.x) + 0.01, ScaleY(Data^.ptlPixel.y) + 0.01);
  StrokeOrPath;
  if CurrentPen.lopnWidth <> 1 then FPage.SetLineWidth(PosiX * CurrentPen.lopnWidth);
  if Data^.crColor <> CurrentPen.lopnColor then FPage.SetRGBStrokeColor(CurrentPen.lopnColor);
end;

procedure TVPDFWmf.VEMRSETPOLYFILLMODE(Data: PEMRSelectclippath);
begin
  PolyFIllMode := (Data^.iMode = ALTERNATE);
  SetPolyFillMode(DContext, Data^.iMode);
end;

procedure TVPDFWmf.VEMRSETSTRETCHBLTMODE(Data: PEMRSetStretchBltMode);
begin
  BLMode := Data^.iMode;
  SetStretchBltMode(DContext, data^.iMode);
end;

procedure TVPDFWmf.VEMRSETVIEWPORTEXTEX(Data: PEMRSetViewportExtEx);
begin
  ViewportExtEx := Data^.szlExtent.cx;
  ViewportExtEy := Data^.szlExtent.cy;
  SetViewportExtEx(DContext, Data^.szlExtent.cx, data^.szlExtent.cy, nil);
end;

procedure TVPDFWmf.VEMRSETVIEWPORTORGEX(Data: PEMRSetViewportOrgEx);
begin
  ViewportOrgEx := Data^.ptlOrigin.X;
  ViewportOrgEy := Data^.ptlOrigin.Y;
  SetViewportOrgEx(DContext, data^.ptlOrigin.X, data^.ptlOrigin.Y, nil);
end;

procedure TVPDFWmf.VEMRSETWINDOWEXTEX(Data: PEMRSetViewportExtEx);
begin
  WinExtEx := data^.szlExtent.cx;
  WinExtEy := Data^.szlExtent.cy;
  SetWindowExtEx(DContext, data^.szlExtent.cx, Data^.szlExtent.cy, nil);
end;

procedure TVPDFWmf.VEMRSETWINDOWORGEX(Data: PEMRSetViewportOrgEx);
begin
  WinOrgEx := Data^.ptlOrigin.X;
  WinOrgEy := Data^.ptlOrigin.Y;
  SetWindowOrgEx(DContext, Data^.ptlOrigin.X, Data^.ptlOrigin.Y, nil);
end;

procedure TVPDFWmf.VEMRSETWORLDTRANSFORM(Data: PEMRSetWorldTransform);
begin
  ZScaleX := Data^.xform.eM11;
  ZScaleY := Data^.xform.eM22;
  XOffset := Data^.xform.eDx * PosiX;
  YOffset := Data^.xform.eDy * PosiY;
  if WTransform then SetWorldTransform(DContext, Data^.xform)
  else Move(Data^.xform, lpXForm, SizeOf(lpXForm));
end;

procedure TVPDFWmf.VEMRSETSTRETCHBLT(Data: PEMRStretchBlt);
var
  I: Integer;
  BMTemp: TBitmap;
  BMInfo: PBitmapInfo;
  BMCanvas: TBitmap;
  BMBits: Pointer;
begin
  if (Data^.offBmiSrc > 0) and (Data^.offBitsSrc > 0) then
  begin
    BMInfo := Displace(Data, Data^.offBmiSrc);
    BMBits := Displace(Data, Data^.offBitsSrc);
    BMTemp := TBitmap.Create;
    try
      BMTemp.Width := BMInfo^.bmiHeader.biWidth;
      BMTemp.Height := BMInfo^.bmiHeader.biHeight;
      StretchDIBits(BMTemp.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height, 0, 0,
        BMTemp.Width, BMTemp.Height, BMBits, BMInfo^, Data^.iUsageSrc, SRCCOPY);
      BMCanvas := TBitmap.Create;
      try
        BMCanvas.Width := abs(Data^.cxDest);
        BMCanvas.Height := abs(Data^.cyDest);
        StretchBlt(BMCanvas.Canvas.Handle, 0, 0, BMCanvas.Width, BMCanvas.Height,
          BMTemp.Canvas.Handle, 0, 0, BMTemp.Width, BMTemp.Height, Data^.dwRop);
        if BMCanvas.PixelFormat = pf1bit then I := FPage.FParent.AddImage(BMCanvas, icCCITT42)
        else I := FPage.FParent.AddImage(BMCanvas, 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
        BMCanvas.Free;
      end;
    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.VEMRSTRETCHDIBITS(Data: PEMRStretchDiBits);
var
  I: Integer;
  BMWidth: Integer;
  BMHeight: Integer;
  BMObj: HGDIOBJ;
  PrevBMObj: HGDIOBJ;
  BMTemp: TBitmap;
  BMBits: Pointer;
  BMInfo: PBitmapInfo;
  DContext, ScreenDC: HDC;
begin
  BMInfo := Displace(Data, Data^.offBmiSrc);
  BMBits := Displace(Data, Data^.offBitsSrc);
  if BMInfo^.bmiHeader.biBitCount = 1 then
  begin
    BMObj := CreateBitmap(BMInfo^.bmiHeader.biWidth, BMInfo^.bmiHeader.biHeight, 1, 1, nil);
    ScreenDC := GetDC(0);
    DContext := CreateCompatibleDC(ScreenDC);
    PrevBMObj := SelectObject(DContext, BMObj);
    try
      StretchDIBits(DContext, 0, 0, BMInfo^.bmiHeader.biWidth,
        BMInfo^.bmiHeader.biHeight,
        Data^.xSrc, Data^.ySrc, Data^.cxDest, Data^.cyDest, BMBits, BMInfo^,
        Data^.iUsageSrc, Data^.dwRop);
      BMTemp := TBitmap.Create;
      try
        BMTemp.Handle := BMObj;
        I := FPage.FParent.AddImage(BMTemp, icCCITT42);
        if (Data^.rclBounds.Right - Data^.rclBounds.Left > 0) and
          (Data^.rclBounds.Bottom - Data^.rclBounds.Top > 0) then
          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)
        else
          FPage.ShowImage(I, ScaleX(Data^.xDest), ScaleY(Data^.yDest),
            ScaleX(data^.cxDest, False), ScaleY(Data^.cyDest,
            False), 0);
        BMTemp.ReleaseHandle;
      finally
        BMTemp.Free;
      end;
    finally
      SelectObject(DContext, PrevBMObj);
      DeleteDC(DContext);
      ReleaseDC(0, ScreenDC);
    end;
  end
  else
  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, Data^.dwRop);
      if BMInfo^.bmiHeader.biBitCount = 1 then
      begin
        BMTemp.PixelFormat := pf1bit;
        I := FPage.FParent.AddImage(BMTemp, icCCITT42)
      end