pdfobjs.pas

delphi7报表打印控件源码 可以设计报表

unit pdfobjs;
////////////////////////////////////////////////////////////////////////////
//  Unit : pdfobjs.pas
//
//  PDF routines : based on PDF Spec 1.3
//
//
//  (c) 2001, 2002, 2003 QBS Software
//      created 10th October 2001 by DLMentz
//
// This code may not be reproduced for any purpose whatever nor any
// changes made without written permission from QBS Software.
//
// 04 th dec 2002 added compression see QRPDFFilt.pas.
// 15th Jan 2002 fix compression option and add ZapfDingbats.
// 15th March 2003 added DocumentInfo
// 30th April 2003 Fixed temp directory path on first page.
// 28/12/2003 added TrueType embedding
// 01/01/04  NO MORE TEMPFILES !!!
// 02/02/004  Charset property for TTFonts
////////////////////////////////////////////////////////////////////////////
{$DEFINE notTEMPFILES}

interface
uses
  Windows, Messages, SysUtils, Classes, graphics, math, ExtCtrls;

const
  BaseFamilies: array[0..5] of string = (
    'Courier',
    'Helvetica',
    'Times',
    'Symbol',
    'ZapfDingbats',
    'STSong-Light');

  BaseFonts: array[0..14] of string = (
    'Courier',
    'Courier-Bold',
    'Courier-BoldOblique',
    'Courier-Oblique',
    'Helvetica',
    'Helvetica-Bold',
    'Helvetica-BoldOblique',
    'Helvetica-Oblique',
    'Times-Roman',
    'Times-Bold',
    'Times-Italic',
    'Times-BoldItalic',
    'Symbol',
    'ZapfDingbats',
    'AdobeSongStd-Light-Acro');
  // don't use enum type because of DLL packaging
  IT_TEXT = 1;
  IT_NEWPAGE = 2;
  IT_GRAPHIC = 3;
  IT_IMAGE = 4;
  // shapes
  S_BOX = 0;
  S_CIRCLE = 1;
  S_HLINE = 2;
  S_VLINE = 3;
  S_OBLIQUE = 4;
  S_TOPBOTTOM = 5;
  S_LEFTRIGHT = 6;
  // ascii
  ORD0 = ord('0');
  ORDA = ord('A');
  CRLF = chr($0D) + chr($0A);
  // TT font files
  TTFheader = 12;
  TABDIR = 16;

type
  TRGBColor = record
    red, green, blue: byte;
  end;

  TTFontrec = record
    firstchar, lastchar, capheight, italica, stemv,
      stemh, xheight: integer;
    flags, NumMetrics, MapMode: integer;
    ascent, descent: short;
    filelength: dword;
    BBox: array[0..3] of short;
    metrics: array of integer;
  end;

  TPDFItemRec = record
    ItemType: byte;
    Xpos, Ypos: extended;
    Fontname, FText: pchar;
    fontsize: integer;
    fcolor: pchar;
    fbold, fitalic: boolean;
    fAlignment: byte;
      // extra for graphic item
    filled, staticimage: boolean;
    width, height, thickness, xscale, yscale: extended;
    imagesrc: pchar;
    imagestring: string;
    shape: byte;
    pixelwidth, pixelheight: integer;
    rgbstrokecolor: TRGBColor;
    rgbfcolor: TRGBColor;
  end;

  TPDFPrintItem = class(TObject)
  private
  public
    Data: TPDFItemRec;
    imagedata: TStringlist;
    imagefile: pchar;
    constructor create;
    destructor Destroy; override;
  end;

  TPDFPageObj = class(TObject)
  private
  public
    imagedata, textdata: string;
    textlen, grlen: longint;
  end;

var
  CompressionOn, MadeFirstPageFiles: boolean;
  UseTTFonts: boolean;
  TextFirst: boolean;
  OutputStream: TStream;
  Docdate, DocSubject, DocTitle, DocAuthor: string;
  OldSeparator: char;
   // debug vars
  debugstr: string;
  debugbuff: array[0..50] of byte;
  debugint: integer;
  FCharset: TFontCharset;
  // exports
procedure CloseDownLib;
procedure InitLib(Mother: pointer);
procedure AddPDFItem(ItemRec: TPDFItemRec);
procedure AddImageItem(ItemRec: TPDFItemRec; imgdata: pointer);
procedure SetPageParams(w, h, tm, tma, lma: extended);
procedure AddFontSub(ssmap: string);
procedure FinishDoc(FOutFile: string);
procedure SetTextFirst(bval: boolean);
procedure SetTempDirectory(tpath: string);
procedure SetFiltCompression(OnOff: integer);
procedure SetOutputStream(pstr: TStream);
procedure SetDocProperties(author, title, subject: string);
procedure EmbedTTFont(fontname: string);
procedure SelectCharset(chars: TFontCharset);
  // end exports
procedure FinishPage;
procedure StartPage;
procedure MakeResourceDict;
procedure MakeTTFont(fontname, stylename: string; fnumber: integer);
procedure MakeXRef;
function MapFontName(oldname: string): string;
function IsNumber(s: string): boolean;
function Pad10(s: string): string;
function RGBString(acol: TRGBColor): string;
procedure HEXImage(ffi: string);
function PDFArcTo(X1, Y1, X2, Y2, XRadius, YRadius: Extended): string;
procedure RunLength(source, Target: TStream);
procedure ASCII85(Source, Target: TStream; soffset: longint);

implementation
uses pdfconst;

var
  fontrec: TTFontrec;
  buff: array of byte;
  CurrObject, VertAdjust: integer;
  Pagewidth, Pageheight, TopMargin, adjusttm, adjustlm: extended;
  imagecount, pagenumber: longint;
  XRefBytes: tstringlist;
  DocTop, PagesList: TStringlist;
  fontlist: TStringlist;
  TextItems, FontSubs: TStringList;
  pagetextfiles, pagegraphicsfiles: TStringlist;
{$IFDEF TEMPFILES}
  CurrPageFile, CurrImageFile: TFilestream;
{$ELSE}
  CurrPageFile, CurrImageFile: TStringlist;
{$ENDIF}
  textlength, graphicslength: longint;
  textlengths, graphicslengths, ttfonts: TStringlist;
  docstream, tempstream: TStream;
  docstreamlen: longint;
  TempDirectory: string;

constructor TPDFPrintItem.create;
begin
  inherited;
  data.Fontname := nil;
  data.Ftext := nil;
  ImageFile := nil;
end;

destructor TPDFPrintItem.Destroy;
begin
  if data.Fontname <> nil then freemem(data.Fontname);
  if assigned(data.Ftext) then freemem(data.Ftext);
  if assigned(ImageFile) then freemem(ImageFile);
  inherited;
end;

function cvtDWord(buf: array of byte; p: integer): dword;
begin
  result := (256 * 256 * 256 * buf[p]) + (256 * 256 * buf[p + 1]) + (256 * buf[p + 2]) + buf[p + 3];
end;

function cvtInt(buf: array of byte; p: integer): integer;
begin
  result := (256 * buf[p]) + (buf[p + 1]);
end;

procedure InitLib(mother: pointer);
begin
    // global creations
  XRefBytes := TStringlist.create;
  Pageslist := TStringlist.create;
  Fontlist := TStringlist.create;
  TextItems := TStringlist.create;
  textlengths := TStringlist.create;
  graphicslengths := TStringlist.create;
  ttfonts := TStringlist.create;
  pagetextfiles := TStringlist.create;
  pagegraphicsfiles := TStringlist.create;
  TempDirectory := '';
    // start a new page
  pagenumber := 0;
    // don't do this beacuse the temp path is not set.
    //Startpage;
  MadeFirstPageFiles := false;
    // load default font subs
  FontSubs := TStringlist.create;
  fontsubs.add('Arial:Helvetica');
  fontsubs.add('Times-new-roman:Times');
  fontsubs.add('Courier-new:Courier');

  VertAdjust := 20; // points
  imagecount := 0;
  Pagewidth := 595;
  Pageheight := 840;
  UseTTFonts := false;
    // ensure decimal separator
  OutputStream := nil;
  OldSeparator := DecimalSeparator;
end;

procedure EmbedTTFont(fontname: string);
begin
  ttfonts.add(fontname);
end;

procedure SelectCharset(chars: TFontCharset);
begin
  FCharset := chars;
end;

procedure CloseDownLib;
var
  k: integer;
begin
      // global free
  Fontlist.free;
  xrefbytes.free;
  fontsubs.free;
  pagetextfiles.free;
  textlengths.free;
  ttfonts.Free;
  graphicslengths.free;
  DecimalSeparator := OldSeparator;
  for k := 0 to pagegraphicsfiles.Count - 1 do
    TStringlist(pagegraphicsfiles.objects[k]).Free;
  pagegraphicsfiles.free;
end;

procedure SetDocProperties(author, title, subject: string);
begin
  DocAuthor := author;
  DocTitle := title;
  DocSubject := subject;
end;

procedure SetOutputStream(pstr: TStream);
begin
  OutputStream := pstr;
end;

procedure SetTempDirectory(tpath: string);
begin
  TempDirectory := IncludeTrailingBackslash(tpath);
end;

procedure SetFiltCompression(OnOff: integer);
begin
  CompressionOn := onoff > 0;
end;

procedure SetPageParams(w, h, tm, tma, lma: extended);
begin
  pagewidth := w;
  pageheight := h;
  topmargin := tm;
  adjusttm := tma;
  adjustlm := lma;
end;

procedure SetTextFirst(bval: boolean);
begin
  TextFirst := bval;
end;

procedure AddFontSub(ssmap: string);
var
  k: integer;
begin
    // expecting 'Name-to-be-mapped: base-font'
  k := fontsubs.indexof(ssmap);
  if k <> -1 then
    fontsubs[k] := ssmap
  else
    fontsubs.add(ssmap);
end;

procedure WriteStr(ob: string);
var
  k, b: integer;
begin
  ob := ob + CRLF;
  for k := 1 to length(ob) do
  begin
    b := ord(ob[k]);
    docstream.WriteBuffer(b, 1);
  end;
  inc(docstreamlen, length(ob));
end;

procedure WriteStrNoCRLF(ob: string);
var
  k, blen: integer;
  bbuff: array of byte;
begin
  blen := length(ob);
  setlength(bbuff, blen);
  for k := 1 to blen do
  begin
    bbuff[k - 1] := ord(ob[k]);
  end;
  docstream.WriteBuffer(bbuff[0], blen);
  inc(docstreamlen, blen);
  setlength(bbuff, 0);
end;

procedure WriteStrNoCRLFold(ob: string);
var
  k, b: integer;
begin
  for k := 1 to length(ob) do
  begin
    b := ord(ob[k]);
    docstream.WriteBuffer(b, 1);
  end;
  inc(docstreamlen, length(ob));
end;

procedure WriteByte(ob: byte);
var
  b: integer;
begin
  b := ob;
  docstream.WriteBuffer(b, 1);
  inc(docstreamlen);
end;

procedure SaveOffset;
begin
       //xrefbytes.add( format( '%-10.10d', [ length( doctop.text )] ));
  xrefbytes.add(format('%-10.10d', [docstreamlen]));
end;

procedure FinishDoc(FOutFile: string);
var
  k, j, p: integer;
  newfname, kidstring, stylename: string;
  streamlen: longint;
  pagetext: TStringlist;
begin
  FinishPage;
  Doctop := TStringlist.create;
   //fontobjlines := TStringlist.create;
  pagetext := TStringlist.create;
  docstreamlen := 0;
  if OutputStream = nil then
    docstream := TFilestream.Create(FOutFile, fmCreate)
  else
    docstream := OutputStream;

   // Root catalog
  WriteStr('%PDF-1.2');
  {
  SaveOffset;
  WriteStr('1 0 obj');
  WriteStr('<<');
  WriteStr('/Type /Catalog');
  WriteStr('/Pages 3 0 R');
  WriteStr('/Outlines 2 0 R');
  WriteStr('/ViewerPreferences << /HideToolbar false /FitWindow true >>');
  WriteStr('>>');
  WriteStr('endobj');
   // empty outlines ( for the moment )
  SaveOffset;
  WriteStr('2 0 obj');
  WriteStr('<<');
  WriteStr('/Type /Outlines');
  WriteStr('/Count 0');
  WriteStr('>>');
  WriteStr('endobj');
   // Pages object
  SaveOffset;
  WriteStr('3 0 obj');
  WriteStr('<<');
  WriteStr('/Type /Pages');
  WriteStr(format('/Count %d', [pagenumber]));
  kidstring := '/Kids [';
  for k := 0 to pagetextfiles.count - 1 do
    kidstring := kidstring + format('%d 0 R ', [4 + (2 * k)]);
  kidstring := trim(kidstring) + ']';
  WriteStr(kidstring);
   // global stuff inherited by page objs
  WriteStr(format('/MediaBox [0 0 %d %d]', [trunc(pagewidth), trunc(pageheight)]));
  MakeResourceDict;
  WriteStr('>>');
  WriteStr('endobj');
  CurrObject := 3;
  SaveOffset; }
  CurrObject := 1;
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Type /Catalog');
  WriteStr('/Pages 3 0 R');
  WriteStr('/Outlines 2 0 R');
  WriteStr('>>');
  WriteStr('endobj');
  inc(currobject);
  SaveOffset;
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Type /Outlines');
  WriteStr('/Count 0');
  WriteStr('>>');
  WriteStr('endobj');
  inc(currobject);
  SaveOffset;
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Type /Pages');
  WriteStr('/Count 1');
  WriteStr('/Kids [ 5 0 R ]');
  WriteStr('>>');
  WriteStr('endobj');
  inc(currobject);
  SaveOffset;
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('[/PDF /Text]');
  WriteStr('endobj');
  inc(currobject);
  SaveOffset;
  for j := 0 to pagetextfiles.count - 1 do
  begin
    streamlen := strtoint(textlengths[j]) + strtoint(graphicslengths[j]) + 4;
       {WriteStr( trim(format( '%d 0 obj', [CurrObject+1])));
       WriteStr( '<<' );
       WriteStr( '/Type /Page' );
       WriteStr( '/Parent 3 0 R' );
       WriteStr( format( '/Contents %d 0 R',[CurrObject+2]) );
       WriteStr( '>>' );
       WriteStr( 'endobj' );

       // Page contents object
       SaveOffset;}

    WriteStr(trim(format('%d 0 obj', [CurrObject])));
    WriteStr('<<');
    WriteStr('/Type /Page');
    WriteStr('/Parent 3 0 R');
    WriteStr('/Resources <<');
    WriteStr('/Font <<');
    WriteStr('/Fcpdf0 7 0 R');
    WriteStr('>>');
    WriteStr('/ProcSet 4 0 R >>');
    WriteStr('/MediaBox [0 0 612 792]');
    WriteStr('/CropBox [0 0 612 792]');
    WriteStr('/Rotate 0');
    WriteStr( format( '/Contents %d 0 R',[CurrObject+1]) );
    //WriteStr('/Contents 6 0 R');
    WriteStr('>>');
    WriteStr('endobj');
    inc(currobject);
    SaveOffset;
    WriteStr(trim(format('%d 0 obj', [CurrObject])));
    WriteStr(format('<< /Length %d >>', [streamlen]));
    WriteStr('stream');
       // optional order of printing.
    if TextFirst then
    begin
      WriteStr('BT');
{$IFDEF TEMPFILES}
           // insert the page instructions here
      tempstream := TFilestream.Create(pagetextfiles[j], fmOpenRead);
      docstream.CopyFrom(tempstream, tempstream.Size);
      inc(docstreamlen, tempstream.size);