teepdfcanvas.pas

BCB第三方组件

          WriteStringToStream(FCStream,' h f'+CRLF)
    else
    if DrawPie then
       WriteStringToStream(FCStream,' s'+CRLF)
    else
    if Not DrawPie then
       WriteStringToStream(FCStream,' S'+CRLF);

    if a<>b then
       WriteStringToStream(FCStream,'Q'+CRLF);
  end;
end;

{ Transform individual chars to double byte hex codes}
function TPDFCanvas.TextToPDFText(const AText: String): String;
var i : Integer;
begin
  Result := '';
  for i := 1 to Length(AText) do
    Result := Result + IntToHex(Ord(AText[i]), 2);
end;

function TPDFCanvas.TextHeight(const St: String): Integer;
begin
  Result := inherited TextHeight(St);
end;

function TPDFCanvas.TextWidth(const St: String): Integer;
begin
  Result := inherited TextWidth(St);
end;

procedure TPDFCanvas.InternalDrawImage(const sx, sy, tx,ty: double;
  ImageIndex: Integer);
begin
  WriteStringToStream(FCStream,'q ');

  tmpSt := FormatFloat('0.000',sx) + ' 0 0 ' +
           FormatFloat('0.000',sy) + ' ' +
           FormatFloat('0.000',tx) + ' ' +
           FormatFloat('0.000',ty);

  FixSeparator(tmpSt);

  tmpSt := tmpSt + ' cm /Im'+ IntToStr(ImageIndex)+' Do Q';
  WriteStringToStream(FCStream, tmpSt+CRLF);
end;

procedure TPDFCanvas.SetEmbeddedFonts(const Value: boolean);
begin
  FEmbeddedFonts := Value;
end;

procedure TPDFCanvas.WriteToStream(AStream: TStream);
begin
end;

Function TPDFCanvas.BeginBlending(const R:TRect; Transparency:TTeeTransparency):TTeeBlend;
begin
  result:=nil;
end;

procedure TPDFCanvas.EndBlending(Blend:TTeeBlend);
begin
//
end;

Constructor TPDFCanvas.Create(AChartObject: TPDFChartObject);
begin
  inherited Create;
  UseBuffer := False;
  FContents := AChartObject;
  FCStream := FContents.Contents;
end;

{ TPDFExportFormat }
function TPDFExportFormat.Description: String;
begin
  result:=TeeMsg_AsPDF;
end;

function TPDFExportFormat.FileExtension: String;
begin
  result:='pdf';
end;

function TPDFExportFormat.FileFilter: String;
begin
  result:=TeeMsg_PDFFilter;
end;

procedure TPDFExportFormat.DoCopyToClipboard;
(*var
  buf: PChar;
  buflen : Integer;
  *)
begin
  (*With PDFPage do
  try
    bufLen := Size;
    Position := 0;
    buf := AllocMem(buflen+1);
    try
      Read(buf^,buflen+1);
      ClipBoard.AsText:=buf; // SetTextBuf(buf);
    finally
      FreeMem(buf);
    end;
  finally
    Free;
  end;
  *)
end;

function TPDFExportFormat.Options(Check:Boolean): TForm;
begin
  result:=nil;
end;

procedure TPDFExportFormat.SaveToStream(Stream: TStream);
begin
  with PDFPage do
  try
    SaveToStream(Stream);
  finally
    Free;
  end;
end;

{$IFNDEF CLR}
type
  TTeePanelAccess=class(TCustomTeePanel);
{$ENDIF}

function TPDFExportFormat.PDFPage: TTeePDFPage;
var tmp : TCanvas3D;
begin { return a panel or chart in PDF format into a StringList }
  CheckSize;
  Result := TTeePDFPage.Create;
  Panel.AutoRepaint := False;
  try
    tmp := Panel.Canvas;
    {$IFNDEF CLR}  // Protected across assemblies
    TTeePanelAccess(Panel).InternalCanvas:=nil;
    {$ENDIF}

    Result.PageWidth := Width;
    Result.PageHeight := Height;
    Panel.Canvas := TPDFCanvas.Create(Result.ChartObject);

    if not Assigned(Panel.Parent) then
      Panel.BufferedDisplay:=True;  // 7.01

    try
      Panel.Draw(Panel.Canvas.ReferenceCanvas,TeeRect(0,0,Width,Height));
    finally
      Panel.Canvas:=tmp;
    end;
  finally
    Panel.AutoRepaint:=True;
  end;
end;

procedure TeeSaveToPDFFile( APanel:TCustomTeePanel; const FileName: WideString;
                            AWidth:Integer=0;
                            AHeight: Integer=0);
begin { save panel or chart to filename in VML (html) format }
  with TPDFExportFormat.Create do
  try
    Panel:=APanel;
    Height:=AHeight;
    Width:=AWidth;
    SaveToFile(FileName);
  finally
    Free;
  end;
end;

procedure TPDFCanvas.TranslateVertCoord(var Y: double);
begin
  { vertical coordinate is reversed in PDF !! }
  Y := IHeight - Y;
end;

function TPDFCanvas.SetPenStyle(PenStyle: TPenStyle): String;
begin
  case PenStyle of
    psSolid   : Result := '[ ] 0 d';
    psDash    : Result := '[3 3] 0 d';
    psDot     : Result := '[2] 1 d';
    psDashDot : Result := '[3 2] 2 d';
  else
                Result := '[ ] 0 d';
  end;
end;

function TPDFCanvas.PenProperties: String;
begin
  Result := PDFColor(Pen.Color)+ ' RG ' +
            IntToStr(IPenWidth)+' w ' +
            SetPenStyle(IPenStyle)+ ' ';
  // v8.01
  if (Pen is TChartPen) then
    with (Pen as TChartPen) do
    begin
      case EndStyle of
        esRound: Result := Result +' 1 J ';
        esSquare: Result := Result +' 2 J ';
        else Result := Result + ' 0 J ';
      end;
    end;
end;

function TPDFCanvas.BrushProperties: String;
begin
  Result := PDFColor(Brush.Color)+' rg';
end;

Destructor TPDFCanvas.Destroy;
begin
  inherited Destroy;
end;

function TPDFCanvas.FontProperties(Font: TTeeFont; var FontIndex: Integer): String;
begin
  FontIndex := SelectFont(Font);
  Result := '/F'+ IntToStr(FontIndex) + ' ' +
            IntToStr(Font.Size)+ ' Tf '+
            IntToStr(Font.InterCharSize) + ' Tc ';
end;

{ TFontListEntry }
Constructor TTeePDFFontListEntry.Create(AFont: TFont);
begin
  inherited Create;
  FPDFName := PDFFontName(AFont);
  DefineFontData(AFont);
end;

procedure TTeePDFFontListEntry.DefineFontData(AFont: TFont);
var FontInfo: {$IFDEF CLR}Array[0..0] of {$ELSE}^{$ENDIF}TOutlineTextMetric;
    fnt: HFont;
    m_hdcFont: HDC;
begin
  {$IFNDEF CLR}
  New(FontInfo);
  {$ENDIF}
  try
    fnt := CreateFont(-1000, 0, 0, 0, FW_DONTCARE, 0, 0, 0,
                      {$IFDEF CLX}
                      1
                      {$ELSE}
                      DEFAULT_CHARSET
                      {$ENDIF},
                      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
                      DEFAULT_QUALITY, DEFAULT_PITCH or FF_DONTCARE,
                      {$IFNDEF CLR}PChar{$ENDIF}(AFont.Name));
    m_hdcFont := GetDC(0);

    SelectObject(m_hdcFont, fnt);
    DeleteObject( fnt );

    GetOutlineTextMetrics(m_hdcFont,SizeOf(TOutlineTextMetric),FontInfo);

    With FFontData do
    begin
      DigAspX := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmDigitizedAspectX;
      DigAspY := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmDigitizedAspectY;
      FontBBox := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmrcFontBox;
      FirstChar := Ord(FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmFirstChar);
      LastChar := Ord(FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmLastChar);
      CapHeight := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmsCapEmHeight;
      Ascent := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmAscent;
      Descent := -FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmDescent;
      MaxWidth := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmMaxCharWidth;
      AvgWidth := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmTextMetrics.tmAveCharWidth;
      ItalicAngle := FontInfo{$IFDEF CLR}[0]{$ENDIF}.otmItalicAngle;

      GetCharWidth(m_hdcFont,0,255,CharWidths);
    end;
  finally
    {$IFNDEF CLR}
    Dispose(FontInfo);
    {$ENDIF}
  end;
end;

{ TFontList }

function TTeePDFFontList.AddItem(AFont: TFont; AHandle: TTeeCanvasHandle): Integer;
begin
  Result := IFontList.Add(TTeePDFFontListEntry.Create(AFont));
end;

constructor TTeePDFFontList.Create;
begin
  inherited;
  IFontList := TList.Create;
end;

destructor TTeePDFFontList.Destroy;
var i: Integer;
begin
  for i := 0 to IFontList.Count - 1 do
      TTeePDFFontListEntry(IFontList.Items[i]).Free;

  IFontList.Free;

  inherited Destroy;
end;

function TTeePDFFontList.Find(AFont: TFont): Integer;
var i: Integer;
    tmpName: String;
begin
  Result := -1;

  tmpName := PDFFontName(AFont);

  for i := 0 to IFontList.Count - 1 do
    if tmpName = TTeePDFFontListEntry(IFontList.Items[i]).PDFName then
    begin
      Result := i;
      Break;
    end;
end;

function TTeePDFFontList.GetCount: Integer;
begin
  Result := IFontList.Count;
end;

function TTeePDFFontList.GetFontEntry(Index: Integer): TTeePDFFontListEntry;
begin
  Result := TTeePDFFontListEntry(IFontList.Items[Index]);
end;

function TPDFExportFormat.ChartObject: TPDFChartObject;
var tmp : TCanvas3D;
begin { return a panel or chart in PDF format into a StringList }
  CheckSize;

  Result := TPDFChartObject.Create;
  Panel.AutoRepaint := False;
  try
    tmp := {$IFNDEF CLR}TTeePanelAccess{$ENDIF}(Panel).InternalCanvas;
    {$IFNDEF CLR}TTeePanelAccess{$ENDIF}(Panel).InternalCanvas := nil;

    Panel.Canvas := TPDFCanvas.Create(Result);

    if not Assigned(Panel.Parent) then
       Panel.BufferedDisplay:=True;  // 7.01

    try
      Panel.Draw(Panel.Canvas.ReferenceCanvas,TeeRect(0,0,Width,Height));
    finally
      Panel.Canvas:=tmp;
    end;
  finally
    Panel.AutoRepaint:=True;
  end;
end;

{ TPDFChartObject }

constructor TPDFChartObject.Create;
begin
  inherited Create;
  FFontArray := TTeePDFFontList.Create;
  FImageArray := TTeePDFImageList.Create;
  FContents := TMemoryStream.Create;
end;

destructor TPDFChartObject.Destroy;
begin
  FFontArray.Free;
  FImageArray.Free;
  FContents.Free;
  inherited;
end;

function TPDFChartObject.GetLength: Integer;
begin
  Result := FContents.Size;
end;

procedure TPDFChartObject.SaveToStream(AStream: TStream);
begin
  WriteStringToStream(AStream,'<< /Length '+IntToStr(GetLength)+ ' >>'+CRLF);
  WriteStringToStream(AStream,'stream'+CRLF);
  AStream.CopyFrom(FContents,0);
  WriteStringToStream(AStream,'endstream'+CRLF);
end;

{ TTeePDFPage }

procedure TTeePDFPage.AddToOffset(Offset: Integer);
begin
  OffsetList.Add(FormatIntToString(OffSet, 10));
end;

constructor TTeePDFPage.Create;
begin
  inherited Create;
  IObjCount := 0;
  FChartObject := TPDFChartObject.Create;
  OffsetList := TStringList.Create;
end;

destructor TTeePDFPage.Destroy;
begin
  FChartObject.Free;
  OffsetList.Free;  // 7.07
  inherited;
end;

procedure TTeePDFPage.SaveToStream(AStream: TStream);
begin
  WriteHeader(AStream);
  WriteInfo(AStream);

  // write chart canvas code
  Inc(IObjCount);
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+ ' 0 obj'+CRLF);
  FChartObject.SaveToStream(AStream);
  WriteStringToStream(AStream,'endobj'+CRLF);

  // TT fonts
  WriteTTFonts(AStream);

  // Additional images, if they exist
  WriteImages(AStream);

  // Resources
  WriteResources(AStream);

  // Pages and page
  WritePages(AStream);
  WritePage(AStream);

  WriteCatalog(AStream);
  WriteXRef(AStream);
  WriteStringToStream(AStream,'%%EOF'+CRLF);
end;

procedure TTeePDFPage.SetPageHeight(const Value: Integer);
begin
  FPageHeight := Value;
end;

procedure TTeePDFPage.SetPageWidth(const Value: Integer);
begin
  FPageWidth := Value;
end;

procedure TTeePDFPage.WriteCatalog(AStream: TStream);
begin
  Inc(IObjCount);