pdfobjs.pas

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

      tempstream.Free;

      tempstream := TFilestream.Create(pagegraphicsfiles[j], fmOpenRead);
      docstream.CopyFrom(tempstream, tempstream.Size);
      inc(docstreamlen, tempstream.size);
      tempstream.Free;

      deletefile(pagetextfiles[j]);
      deletefile(pagegraphicsfiles[j]);
{$ELSE}
      pagetext := TStringlist(pagetextfiles.Objects[j]);
      WriteStrNoCRLF(pagetext.GetText);

      pagetext := TStringlist(pagegraphicsfiles.Objects[j]);
      WriteStrNoCRLF(pagetext.GetText);

{$ENDIF}
    end
    else
    begin
           // graphics
{$IFDEF TEMPFILES}
      tempstream := TFilestream.Create(pagegraphicsfiles[j], fmOpenRead);
      docstream.CopyFrom(tempstream, tempstream.Size);
      inc(docstreamlen, tempstream.size);
      tempstream.Free;
           // text
      WriteStr('BT');
      tempstream := TFilestream.Create(pagetextfiles[j], fmOpenRead);
      docstream.CopyFrom(tempstream, tempstream.Size);
      inc(docstreamlen, tempstream.size);
      tempstream.Free;
      deletefile(pagetextfiles[j]);
      deletefile(pagegraphicsfiles[j]);
{$ELSE}
      pagetext := TStringlist(pagegraphicsfiles.Objects[j]);
      WriteStrNoCRLF(pagetext.GetText);

      WriteStr('BT');
      pagetext := TStringlist(pagetextfiles.Objects[j]);
      WriteStrNoCRLF(pagetext.GetText);

{$ENDIF}
    end;
    WriteStr('endstream');
    WriteStr('endobj');
    inc(currobject);
    SaveOffset;
  end;
  CurrObject := 4 + (2 * pagenumber);
  for k := 0 to fontlist.count - 1 do
  begin
        // now make the font objects
    newfname := trim(fontlist[k]);
    stylename := '';
    p := pos(',', newfname);
    if p > 0 then
    begin
      stylename := trim(copy(newfname, p + 1, 255));
      newfname := trim(copy(newfname, 1, p - 1));
    end;
    if ttfonts.IndexOf(newfname) >= 0 then
    begin
      MakeTTFont(newfname, stylename, k);
    end
    else
    begin
      newfname := MapFontName(fontlist[k]);
           {
           WriteStr( trim(format( '%d 0 obj', [CurrObject] )) );
           WriteStr( '<<' );
           WriteStr( '/Type /Font' );
           WriteStr( '/Subtype /Type1' );
           WriteStr( trim(format('/Name /F%-2.2d', [k] )) );
           WriteStr( '/BaseFont /' + trim(newfname) );
           WriteStr( '/Encoding /WinAnsiEncoding' );
           WriteStr( '>>' );
           WriteStr( 'endobj' );
           inc( currobject );
           SaveOffset;
           }
      WriteStr(trim(format('%d 0 obj', [CurrObject])));
      WriteStr('<<');
      WriteStr('/Type /Font');
      WriteStr('/Subtype /Type0');
      WriteStr('/Name /Fcpdf0');
      WriteStr('/BaseFont /STSong-Light');
      WriteStr('/Encoding /WinAnsiEncoding'); ///GBK-EUC-H' );
      WriteStr('/DescendantFonts [ 9 0 R ]');
      WriteStr('>>');
      WriteStr('endobj');
      inc(currobject);
      SaveOffset;
      WriteStr(trim(format('%d 0 obj', [CurrObject])));
      WriteStr('<<');
      WriteStr('/Type /FontDescriptor');
      WriteStr('/Ascent 880');
      WriteStr('/CapHeight 880');
      WriteStr('/Descent -120');
      WriteStr('/Flags 6');
      WriteStr('/FontBBox [-25 -254 1000 880]');
      WriteStr('/FontName /STSong-Light');
      WriteStr('/ItalicAngle 0');
      WriteStr('/StemV 93');
      WriteStr('/XHeight 616');
      WriteStr('/StemH 93');
      WriteStr('/MissingWidth 500');
      WriteStr('/Leading 250');
      WriteStr('/MaxWidth 1000');
      WriteStr('/AvgWidth 1000');
      WriteStr('/Style << /Panose <010502020400000000000000> >>');
      WriteStr('>>');
      WriteStr('endobj');
      inc(currobject);
      SaveOffset;
      WriteStr(trim(format('%d 0 obj', [CurrObject])));
      WriteStr('<<');
      WriteStr('/Type /Font');
      WriteStr('/Subtype /CIDFontType2');
      WriteStr('/BaseFont /STSong-Light');
      WriteStr('/FontDescriptor 8 0 R');
      WriteStr('/CIDSystemInfo << /Registry (Adobe) /Ordering (GB1) /Supplement 2 >>');
      WriteStr('/DW 1000');
      WriteStr('/W [ 1 95 500 814 939 500 7712 [ 500 ] 7716 [ 500 ] ]');
      WriteStr('>>');
      WriteStr('endobj');
      inc(currobject);
      SaveOffset;
    end;
  end;
   // add an object with the doc properties
  WriteStr(format('%d 0 obj', [CurrObject]));
  WriteStr('<<');
  DocDate := DateTimeToStr(now);
  WriteStr('/CreationDate (' + DocDate + ')');
  WriteStr('/Producer (QuickReports PDF Export)');
  WriteStr('/Subject (' + DocSubject + ' )');
  WriteStr('/Creator (QuickReports)');
  WriteStr('/Title (' + DocTitle + ')');
  WriteStr('/Author (' + DocAuthor + ')');
  WriteStr('>>');
  WriteStr('endobj');
  inc(currobject);
  SaveOffset;

  WriteStr(format('%d 0 obj', [CurrObject]));
  WriteStr('[/PDF /Text]');
  WriteStr('endobj');
  inc(CurrObject);

  MakeXRef;

   // locally created - localy destroyed
  pagetext.Free;
  doctop.free;
  if docstream is TFilestream then
    docstream.free;
end;

procedure MakeXRef;
var
  k, ByteCount: longint;
begin
  bytecount := docstreamlen;
  WriteStr('xref');
  WriteStr(format('0 %d', [xrefbytes.count + 1]));
  WriteStr('0000000000 65535 f');
  for k := 0 to xrefbytes.count - 1 do
    WriteStr(xrefbytes[k] + ' 00000 n');
   // trailer
  WriteStr('trailer');
  WriteStr('<<');
  WriteStr(format('/Size %d', [xrefbytes.count + 1]));
  WriteStr('/Root 1 0 R');
  WriteStr(format('/Info %d 0 R', [xrefbytes.count - 1]));
  WriteStr('>>');
  WriteStr('startxref');
  WriteStr(format('%d', [ByteCount]));
  WriteStr('%%EOF');
end;

function MapFontName(oldname: string): string;
var
  k, p: integer;
  basename, s1: string;
  isbold, isitalic: boolean;
begin
   // oldname is 'fontname[, bold][,italic]'
  isbold := AnsiPos('bold', Ansilowercase(oldname)) > 0;
  isitalic := AnsiPos('italic', Ansilowercase(oldname)) > 0;
  if UseTTFonts then
  begin
    basename := oldname;
    if isbold and isitalic then
      basename := stringreplace(basename, ',italic', 'italic', [rfIgnoreCase]);
    basename := stringreplace(basename, ' ', '', [rfReplaceAll]);
    result := basename;
    exit;
  end;
  k := pos(',', oldname);
  if k > 0 then
    basename := copy(oldname, 1, k - 1)
  else
    basename := oldname;
   // Is it mapped ?
  for k := 0 to fontsubs.count - 1 do
  begin
    s1 := fontsubs[k];
    if AnsiPos(Ansilowercase(basename), Ansilowercase(s1)) = 1 then
    begin
      p := AnsiPos(':', fontsubs[k]);
      if p > 0 then
        basename := copy(fontsubs[k], p + 1, 512)
      else
        basename := 'Courier'; // bad mapping, no colon
      break;
    end;
  end;
  p := AnsiPos('-', basename);
  if p > 0 then
    basename := Copy(basename, 1, p - 1);
   // Do we now have one of the pre-defined type1's
  p := -1;
  for k := 0 to 4 do
    if AnsiSametext(basefamilies[k], basename) then
    begin
      p := k;
      break;
    end;
  if p = -1 then
  begin
    p := 0; // Courier
    basename := 'Courier';
  end;
   // now amend the name to the full name
  case p of
    0, 1: // courier, helv
      if isbold and isitalic then
        basename := basename + '-BoldOblique'
      else if isbold then
        basename := basename + '-Bold'
      else if isitalic then
        basename := basename + '-Oblique';
    2: // Times
      if isbold and isitalic then
        basename := basename + '-BoldItalic'
      else if isbold then
        basename := basename + '-Bold'
      else if isitalic then
        basename := basename + '-Italic'
      else
        basename := basename + '-Roman'
  end;
  result := basename;
end;

procedure GetMetrics(buff: array of byte; offset: dword);
var
  k: word;
begin
  setlength(fontrec.metrics, fontrec.numMetrics);
     // each element is a USHORT and a SHORT
  for k := 0 to fontrec.NumMetrics - 1 do
  begin
    fontrec.metrics[k] := cvtInt(buff, offset + (k * 4));
          //TTFtestfrm.memo1.lines.add( inttostr( metrics[k]));
  end;
end;

procedure AnalyseTTFont(fontname, stylename: string; var encoding: string);
var
  fsize, res, offset, hmtxOff, headOff, boxOff, OS2Off: dword;
  codePage: word;
  k, ntabs, toff, tlen, i, encodingNum: integer;
  tabTag, localfontname, charString: string;
  pbox: TImage;
  Found: boolean;
  otmetric: OUTLINETEXTMETRIC;
  widths: array[0..16000] of integer;
  charCodes: array[0..255] of word;
begin
  pbox := TImage.create(nil);
  hmtxOff := 0;
  headOff := 0;
  OS2Off := 0;
  fsize := 0;
  localfontname := stringreplace(trim(fontname), '-', ' ', [rfReplaceAll]);
  pbox.canvas.Font.Name := localfontname;
  pbox.Canvas.Font.Charset := FCHARSET;

  fontrec.MapMode := GetMapMode(pbox.canvas.handle);
  fontrec.ascent := pbox.canvas.Font.Height;
  pbox.canvas.Font.Height := -1024;

  if lowercase(stylename) = 'bold' then
    pbox.canvas.Font.Style := [fsBold]
  else if lowercase(stylename) = 'italic' then
    pbox.canvas.Font.Style := [fsItalic]
  else if lowercase(stylename) = 'underline' then
    pbox.canvas.Font.Style := [fsUnderline];

  res := GetFontData(pbox.canvas.handle, 0, 0, nil, fsize);
  fsize := res;
  fontrec.filelength := res;
  setlength(buff, fsize);
  res := GetFontData(pbox.canvas.handle, 0, 0, buff, fsize);
  ntabs := cvtInt(buff, 4);
  for k := 0 to ntabs - 1 do
  begin
    offset := (k * TABDIR) + TTFheader;
         // four 4-byte fields
    Tabtag := chr(buff[offset]) + chr(buff[offset + 1]) + chr(buff[offset + 2]) + chr(buff[offset + 3]);
    toff := cvtDWord(buff, offset + 8);
    tlen := cvtDWord(buff, offset + 12);
    if tabTag = 'hmtx' then
      hmtxOff := toff;
    if tabTag = 'head' then
      headOff := toff;
    if tabTag = 'hhea' then
    begin
            // get num metrics, Ascender, Descender.
      fontrec.numMetrics := cvtInt(buff, toff + tlen - 2);
            //fontrec.ascent := cvtInt( buff, toff+4);
            //fontrec.descent := cvtInt( buff, toff+4+2);
    end;
  end;
  GetOutlineTextMetrics(pbox.canvas.handle, sizeof(otmetric), @otmetric);
  fontrec.firstchar := ord(otmetric.otmTextMetrics.tmFirstChar);
  fontrec.lastchar := ord(otmetric.otmTextMetrics.tmLastChar);
  fontrec.ascent := otmetric.otmAscent;
  fontrec.descent := otmetric.otmDescent;
  fontrec.italica := otmetric.otmItalicAngle;
{$DEFINE notOTM}
{$IFDEF OTM}
  setlength(fontrec.metrics, fontrec.NumMetrics);
  GetMetrics(buff, hmtxOff);
{$ELSE}
  fontrec.firstchar := 0;
  fontrec.NumMetrics := fontrec.lastchar - fontrec.firstchar + 1;
  GetCharWidth32(pbox.canvas.handle, fontrec.firstchar, fontrec.lastchar, widths);
  setlength(fontrec.metrics, 256);
  for k := 0 to 255 do
    fontrec.metrics[k] := 1 * widths[k];
{$ENDIF}
     // get fontBBox , flags
  fontrec.flags := cvtInt(buff, HeadOff + 16);
  boxOff := 36;
  fontrec.BBox[0] := cvtInt(buff, headOff + boxOff);
  fontrec.BBox[1] := cvtInt(buff, headOff + boxOff + 2);
  fontrec.BBox[2] := cvtInt(buff, headOff + boxOff + 4);
  fontrec.BBox[3] := cvtInt(buff, headOff + boxOff + 6);
  pbox.Free;
     // get the encoding string
  case FCHARSET of
    BALTIC_CHARSET: CodePage := 1257;
    CHINESEBIG5_CHARSET: CodePage := 950;
    EASTEUROPE_CHARSET: CodePage := 1250;
    GB2312_CHARSET: CodePage := 936;
    GREEK_CHARSET: CodePage := 1253;
    OEM_CHARSET: CodePage := CP_OEMCP;
    RUSSIAN_CHARSET: CodePage := 1251;
    SHIFTJIS_CHARSET: CodePage := 932;
    TURKISH_CHARSET: CodePage := 1254;
    HEBREW_CHARSET: CodePage := 1255;
    ARABIC_CHARSET: CodePage := 1256;
    THAI_CHARSET: CodePage := 874;
    VIETNAMESE_CHARSET: CodePage := 1258;
  else
    CodePage := 1252;
  end;
  charString := '';
  for i := 1 to 255 do
    charString := charString + chr(i);

  k := MultiByteToWideChar(CodePage, 0, PChar(charString), 255, @charCodes, 255);
  if k <> 0 then
  begin
    encoding := ' <</Type/Encoding /Differences [ ' + inttostr(fontrec.firstChar + 2) + ' ';
    for i := 1 to 255 do
    begin
      if i < fontrec.firstchar then continue;
      Found := False;
      for k := 0 to 1050 do
      begin
        if charCodes[i] = UniGlyphs[k].ID then
        begin
          encoding := encoding + '/' + UniGlyphs[k].Name;
          Found := True;
          Break;
        end;
      end;
      if not Found then
      begin
        if charCodes[I] > 256 then
                  //encoding := encoding + '/uni' + WordToHex(charCodes[I])
        else
          encoding := encoding + '/space';
      end;
    end;
    encoding := encoding + ']';
  end
  else
  begin
    encoding := encoding + '/BaseEncoding /WinAnsiEncoding';
  end;
  encoding := encoding + '>>';
end;

procedure MakeTTFont(fontname, stylename: string; fnumber: integer);
var
  k: integer;
  mstr, localname, encoding: string;
begin
  encoding := '';
  AnalyseTTFont(fontname, stylename, encoding);
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Type /Font');
  WriteStr('/Subtype /TrueType');
  localname := trim(format('F%-2.2d', [fnumber]));
  WriteStr(trim(format('/Name /F%-2.2d', [fnumber])));
     {
     if stylename <> '' then
                  WriteStr( '/BaseFont /' + trim(fontname) + ',' + trim(stylename) )
     else
     }
  WriteStr('/BaseFont /' + trim(fontname));
     //fontrec.firstchar := 0;
     //fontrec.lastchar := 255;
  WriteStr('/FirstChar ' + inttostr(fontrec.firstchar));
  WriteStr('/LastChar ' + inttostr(fontrec.lastchar));
     // output the width array
  WriteStr('/Widths [ ');
  mstr := '';
  for k := 0 to high(fontrec.metrics) do
    mstr := mstr + format('%-d ', [fontrec.metrics[k]]);
  WriteStr(mstr + ' ]');
{$DEFINE notENC}
{$IFNDEF ENC}
  WriteStr('/Encoding ' + encoding);
  WriteStr('/FontDescriptor ' + inttostr(CurrObject + 1) + ' 0 R');
{$ELSE}
  WriteStr('/FontDescriptor ' + inttostr(CurrObject + 2) + ' 0 R');
  WriteStr('/Encoding ' + inttostr(CurrObject + 1) + ' 0 R');
{$ENDIF}
  WriteStr('>>');
  WriteStr('endobj');
  SaveOffset;
  inc(currobject);

  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Type /FontDescriptor');
  WriteStr('/Ascent ' + inttostr(fontrec.ascent));
  WriteStr('/Descent ' + inttostr(fontrec.descent));
     //WriteStr( '/CapHeight 700' );
     //WriteStr( '/Flags ' + inttostr(fontrec.flags) );
  WriteStr('/Flags 40');
  WriteStr(format('/FontBBox [ %-d %-d %-d %-d ]', [fontrec.bbox[0],
    fontrec.bbox[1], fontrec.bbox[2], fontrec.bbox[3]]));
  WriteStr('/FontName /' + localname);
  WriteStr('/ItalicAngle ' + inttostr(fontrec.italica));
     //WriteStr( '/StemV ' + inttostr(fontrec.descent) );
     //WriteStr( '/StemH ' + inttostr(fontrec.descent) );
     //WriteStr( '/XHeight ' + inttostr(fontrec.descent) );
  WriteStr('/FontFile2 ' + inttostr(CurrObject + 1) + ' 0 R');
  WriteStr('>>');
  WriteStr('endobj');
  SaveOffset;
  inc(currobject);

  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('<<');
  WriteStr('/Length ' + inttostr(CurrObject + 1) + ' 0 R /Length1 ' + inttostr(CurrObject + 1) + ' 0 R ');
  WriteStr('>>');
  WriteStr('stream');
  mstr := '';
  for k := 0 to fontrec.filelength - 1 do
  begin
    WriteByte(buff[k]);
  end;
  WriteStr(CRLF + 'endstream');
  WriteStr('endobj');
  SaveOffset;
  inc(currobject);
  WriteStr(trim(format('%d 0 obj', [CurrObject])));
  WriteStr('   ' + inttostr(fontrec.filelength));
  WriteStr('endobj');
  SaveOffset;
  inc(currobject);
end;

procedure MakeResourceDict;
var
  k, foff, numfontobjs, p: integer;
  newfname: string;
begin
  WriteStr('/Resources << ');
  WriteStr('/Font << ');
  foff := 0;
  numfontobjs := 0;
  for k := 0 to fontlist.count - 1 do
  begin
    WriteStr(format('  /F%-2.2d %d 0 R ', [k, foff + 4 + (2 * pagenumber)]));
    newfname := trim(fontlist[k]);
    p := pos(',', newfname);
    if p > 0 then
    begin
      newfname := trim(copy(newfname, 1, p - 1));
    end;
    if ttFonts.IndexOf(newfname) >= 0 then
    begin
{$IFNDEF ENC}
      inc(foff, 3);