pdfobjs.pas

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

      inc(numfontobjs, 3);
{$ELSE}
      inc(foff, 4);
      inc(numfontobjs, 4);
{$ENDIF}
    end;
    inc(foff);
    inc(numfontobjs);
  end;
  WriteStr('  >>');
  WriteStr(format('/ProcSet %d 0 R', [5 + (2 * pagenumber) + numfontobjs]));
  WriteStr('>>');
end;

{$IFDEF TEMPFILES}

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

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

procedure StartPage;
var
  thetime: TTimeStamp;
  tmpfile: string;
begin
  inc(pagenumber);
  thetime := DateTimeToTimeStamp(now);
  tmpfile := TempDirectory + format('I%-d%-d%-6.6d.tmp', [thetime.Date, theTime.time, pagenumber]);
  pagetextfiles.Add(tmpfile);
  tmpfile := TempDirectory + format('T%-d%-d%-6.6d.tmp', [thetime.Date, TheTime.time, pagenumber]);
  pagegraphicsfiles.Add(tmpfile);
  currpagefile := TFilestream.Create(pagetextfiles[pagenumber - 1], fmCreate);
  CurrImageFile := TFilestream.Create(pagegraphicsfiles[pagenumber - 1], fmCreate);
  textlength := 0;
  graphicslength := 0;
  MadeFirstPageFiles := true;
end;

procedure FinishPage;
begin
  ptwrite('ET');
  currpagefile.free;
  currimagefile.free;
  textlengths.add(format('%d', [textlength]));
  graphicslengths.add(format('%d', [graphicslength]));
end;
{$ELSE}

procedure PTWrite(ob: string);
begin
  currpagefile.Add(ob);
  inc(textlength, length(ob) + 2);
end;

procedure GRWrite(ob: string);
begin
  CurrImageFile.Add(ob);
  inc(graphicslength, length(ob) + 2);
end;

procedure StartPage;
var
  tmplist: TStringlist;
begin
  inc(pagenumber);
  tmplist := TStringlist.Create;
  currpagefile := tmplist;
  pagetextfiles.AddObject(inttostr(pagenumber), tmplist);
  tmplist := TStringlist.Create;
  pagegraphicsfiles.AddObject(inttostr(pagenumber), tmplist);
  CurrImageFile := tmplist;
  textlength := 0;
  graphicslength := 0;
  MadeFirstPageFiles := true;
end;

procedure FinishPage;
begin
  ptwrite('ET');
  textlengths.add(format('%d', [textlength]));
  graphicslengths.add(format('%d', [graphicslength]));
end;
{$ENDIF}

function FLong(b: array of byte): longint;
begin
  result := b[0];
end;

procedure ProcessItem(ir: TPDFItemRec; pimagefile: string);
var
  fontnum: integer;
  xradius, yradius: extended;
  currfont, tstr, tfname: string;
    //tempfile, compfile : TFilestream;
    //thetime : TTimestamp;
  cc: string;
    //bx : byte;
begin
  DecimalSeparator := '.';
        // transform upside-down
  ir.Ypos := pageheight - ir.ypos;
  ir.ypos := ir.ypos + VertAdjust;
  if ir.itemtype = IT_NEWPAGE then
  begin
    FinishPage;
    StartPage;
    exit;
  end;
  if ir.itemtype = IT_TEXT then
  begin
           // stuff escapes THEN brackets
    tstr := string(ir.FText);
    tstr := stringreplace(tstr, '\', '\\', [rfReplaceAll]);
    tstr := stringreplace(tstr, '(', '\(', [rfReplaceAll]);
    tstr := stringreplace(tstr, ')', '\)', [rfReplaceAll]);
    tfname := string(ir.fontname);
    tfname := stringreplace(tfname, ' ', '-', [rfReplaceAll]);
           // modify the font name with the deco
    if ir.fbold then
      tfname := tfname + ', bold';
    if ir.fitalic then
      tfname := tfname + ', italic';
    fontnum := fontlist.indexof(tfname);
    if fontnum = -1 then
    begin
      fontlist.add(tfname);
      fontnum := fontlist.count - 1;
    end;
           // set the color r g b rg
    ptwrite(RGBString(ir.rgbfcolor) + ' rg');
    currfont := format('F%-2.2d', [fontnum]);
           // output the text rendering instructions
           // try Tm instead of Td
    ptwrite('/' + currfont + format(' %d Tf', [ir.fontsize]));
    ptwrite(format(' 1 0 0 1 %d %d Tm (%s) Tj',
      [trunc(ir.xpos), trunc(ir.ypos), tstr]));
  end; // text items
  if ir.itemtype = IT_GRAPHIC then
  begin
    case ir.shape of
      S_BOX: // 0
        begin
          GRWrite(format('%f w', [ir.thickness]));
          tstr := format('%d %d %d %d re ',
            [trunc(ir.xpos), trunc(ir.ypos - ir.height),
            trunc(ir.width), trunc(ir.height)]);
          if ir.filled then
          begin
            GRWrite(RGBString(ir.rgbfcolor) + ' rg');
            tstr := tstr + 'f'
          end
          else
          begin
            GRWrite(RGBString(ir.rgbstrokecolor) + ' RG');
            tstr := tstr + 's'
          end;
          GRWrite(tstr);
        end;
      S_CIRCLE: // 1
        begin
          GRWrite(format('%2.0f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG');
          XRadius := ir.Width / 2;
          YRadius := ir.Height / 2;
          GRWrite(format('%6.1f ', [ir.xpos + XRadius]) + format('%6.1f', [ir.ypos]) + ' m');
          GRWrite(PDFArcTo(ir.xpos + XRadius, ir.ypos, ir.xpos + ir.Width,
            ir.ypos - YRadius, XRadius, YRadius));
          GRWrite(PDFArcTo(ir.xpos + ir.Width, ir.ypos - YRadius,
            ir.xpos + XRadius, ir.ypos - ir.Height, XRadius, YRadius));
          GRWrite(PDFArcTo(ir.xpos + XRadius, ir.ypos - ir.Height, ir.xpos,
            ir.ypos - YRadius, XRadius, YRadius));
          GRWrite(PDFArcTo(ir.xpos, ir.ypos - YRadius, ir.xpos + XRadius,
            ir.ypos, XRadius, YRadius) + ' s');
        end;
      S_HLINE: // 2
        begin
          GRWrite(format('%2.0f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG'); // stroke colour
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos), trunc(ir.ypos - (ir.height / 2)),
            trunc(ir.xpos + ir.width), trunc(ir.ypos - (ir.height / 2))]);
          GRWrite(tstr);
        end;
      S_VLINE: // 3
        begin
          GRWrite(format('%2.0f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG'); // stroke colour
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos + (ir.width / 2)), trunc(ir.ypos - ir.height),
            trunc(ir.xpos + (ir.width / 2)), trunc(ir.ypos)]);
          GRWrite(trim(tstr));
        end;
      S_OBLIQUE: // 4
        begin
          GRWrite(format('%f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG'); // stroke colour
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos), trunc(ir.ypos),
            trunc(ir.xpos + ir.width), trunc(ir.ypos - ir.height)]);
          GRWrite(tstr);
        end;
      S_TOPBOTTOM: // 4
        begin
          GRWrite(format('%2.0f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG'); // stroke colour
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos), trunc(ir.ypos),
            trunc(ir.xpos + ir.width), trunc(ir.ypos)]);
          GRWrite(tstr);
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos), trunc(ir.ypos - ir.height),
            trunc(ir.xpos + ir.width), trunc(ir.ypos - ir.height)]);
          GRWrite(tstr);
        end;
      S_LEFTRIGHT: // 4
        begin
          GRWrite(format('%2.0f w', [ir.thickness]));
          GRWrite(RGBString(ir.rgbstrokecolor) + ' RG'); // stroke colour
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos), trunc(ir.ypos - ir.height),
            trunc(ir.xpos), trunc(ir.ypos)]);
          GRWrite(trim(tstr));
          tstr := format('%d %d m %d %d l s',
            [trunc(ir.xpos + ir.width), trunc(ir.ypos - ir.height),
            trunc(ir.xpos + ir.width), trunc(ir.ypos)]);
          GRWrite(trim(tstr));
        end;
    end;
  end;
  if ir.itemtype = IT_IMAGE then
  begin
    GRWrite(format('q %d 0 0 %d %d %d cm',
      [trunc(ir.width * ir.xscale), trunc(ir.height * ir.yscale),
      trunc(ir.xpos), trunc(ir.ypos)]));
    GRWrite('BI');
    GRWrite(format('/Width %d', [ir.pixelwidth]));
    GRWrite(format('/Height %d', [ir.pixelheight]));
    GRWrite('/BitsPerComponent 8');
    GRWrite('/ColorSpace /DeviceRGB');
    if CompressionOn then
      GRWrite('/Filter [/ASCIIHexDecode /RunLengthDecode]')
    else
      GRWrite('/Filter [/ASCIIHexDecode]');
    GRWrite('ID');
    GRWrite(ir.imagestring); // the image is asciihex in this string
    cc := '>';
    GRWrite(cc);
    GRWrite('EI');
    GRWrite('Q');
  end;
  DecimalSeparator := OldSeparator;
end;

procedure Hexit(var c1: char; var c2: char; b: byte);
var
  b1, b2: byte;
begin
  b1 := b shr 4;
  b2 := b and $0F;
  if b1 < 10 then
    c1 := chr(b1 + ORD0)
  else
    c1 := chr((b1 - 10) + ORDA);
  if b2 < 10 then
    c2 := chr(b2 + ORD0)
  else
    c2 := chr((b2 - 10) + ORDA);
end;

// Exported : add image

procedure AddImageItem(ItemRec: TPDFItemRec; imgdata: pointer);
begin
  if not MadeFirstPageFiles then StartPage;
  itemrec.ypos := ItemRec.Ypos + topmargin + adjusttm;
  itemrec.Xpos := itemrec.Xpos + adjustlm;
  ProcessItem(itemrec, itemrec.imagesrc);
end;

// Exported procedure - receive item data

procedure AddPDFItem(ItemRec: TPDFItemRec);
begin
  if not MadeFirstPageFiles then StartPage;
  itemrec.ypos := ItemRec.Ypos + topmargin + adjusttm;
  itemrec.Xpos := itemrec.Xpos + adjustlm;
  ProcessItem(itemrec, itemrec.imagesrc);
end;


//======================= Filters ===========================
// this code has not been tested. See QRPDFFilt.pas for working RLE

procedure ASCII85(Source, Target: TStream; soffset: longint);
var
  Bytes: Integer;
  I: Integer;
  Total: Cardinal;
  InBuffer: array[0..3] of Byte;
  OutBuffer: array[0..4] of Byte;
begin

  Source.Position := soffset;
  Target.Position := 0;

  while Source.Position < Source.Size do begin

    for I := 0 to High(InBuffer) do begin
      InBuffer[I] := 0;
    end;

    for I := 0 to High(OutBuffer) do begin
      OutBuffer[I] := 0;
    end;

    Bytes := Source.Read(InBuffer, 4);

    Total := 0;
    for I := 0 to High(InBuffer) do begin
      Total := Total + (InBuffer[I] * Trunc(IntPower(256, 3 - I)));
    end;

    if (Total = 0) and (Bytes = 4) then begin
      OutBuffer[0] := 122;
      Target.Write(OutBuffer, 1);
    end else begin
      for I := 0 to High(OutBuffer) do begin
        OutBuffer[I] := Trunc(Total / IntPower(85, 4 - I));
        Total := Total - (OutBuffer[I] * Trunc(IntPower(85, 4 - I)));
        OutBuffer[I] := OutBuffer[I] + 33;
      end;
      Target.Write(OutBuffer, Bytes + 1);
    end;

  end;

  OutBuffer[0] := Ord('~');
  OutBuffer[1] := Ord('>');
  Target.Write(OutBuffer, 2);

  Source.Position := 0;
  Target.Position := 0;

end;

procedure RunLength(Source, Target: TStream);
var
  Buffer, C, LastOut, LastBuf: string;
  LastCnt: Integer;
begin

  C := ' ';
  Buffer := '';
  LastOut := '';
  LastCnt := 0;
  Source.Position := 0;
  Target.Position := 0;

  while Source.Position < Source.Size do begin

    Source.Read(C[1], 1);

    if (C = LastOut) and (LastCnt <= 127) then begin
      if Length(LastBuf) > 0 then begin
        Buffer := Buffer + CHR(Length(LastBuf) - 1) + LastBuf;
        LastBuf := '';
      end;
      Inc(LastCnt);
    end else begin
      if LastCnt = 0 then begin
      end else if LastCnt > 1 then begin
        Buffer := Buffer + CHR(257 - LastCnt) + LastOut;
      end else begin
        LastBuf := LastBuf + LastOut;
        if Length(LastBuf) >= 128 then begin
          Buffer := Buffer + CHR(Length(LastBuf) - 1) + LastBuf;
          LastBuf := '';
        end;
      end;
      LastCnt := 1;
      LastOut := C;
    end;

    if Length(Buffer) > 0 then begin
      Target.Write(Buffer[1], Length(Buffer));
    end;
    Buffer := '';

  end;

  if Length(LastBuf) > 0 then begin
    Buffer := Buffer + CHR(Length(LastBuf) - 1) + LastBuf;
  end;

  if LastCnt = 1 then begin
    Buffer := Buffer + CHR(0) + LastOut;
  end;

  if LastCnt > 1 then begin
    Buffer := Buffer + CHR(257 - LastCnt) + LastOut;
  end;

  Buffer := Buffer + CHR(128) + '>';
  Target.Write(Buffer[1], Length(Buffer));

  Source.Position := 0;
  Target.Position := 0;
end;

procedure HEXImage(ffi: string);
begin
end;

function RGBString(acol: TRGBColor): string;
begin
  result := trim(format('%4.2f %4.2f %4.2f', [acol.red / 255.0,
    acol.green / 255.0,
      acol.blue / 255.0]));
end;

function Isdigit(c: char): boolean;
begin
  result := (c >= '0') and (c <= '9');
end;

function IsNumber(s: string): boolean;
var
  k: integer;
begin
  result := false;
  for k := 1 to length(s) do
    if not isdigit(s[k]) then
      exit;
  result := true;
end;

function Pad10(s: string): string;
begin
  result := copy('0000000000', 1, 10 - length(s)) + s;
end;
// see AD chapter 10. 'Bezier curves'

function PDFArcTo(X1, Y1, X2, Y2, XRadius, YRadius: Extended): string;
var
  C: array[1..6] of Extended;
  I: Integer;
  W, Y: Extended;
begin
  Result := '';
  C[5] := X2;
  C[6] := Y2;
  W := XRadius * 0.55229;
  Y := YRadius * 0.55229;

  if X2 > X1 then begin
    if Y2 > Y1 then begin
      C[1] := X1;
      C[2] := Y1 + Y;
      C[3] := X2 - W;
      C[4] := Y2;
    end else begin
      C[1] := X1 + W;
      C[2] := Y1;
      C[3] := X2;
      C[4] := Y2 + Y;
    end;
  end else begin
    if Y2 > Y1 then begin
      C[1] := X1 - W;
      C[2] := Y1;
      C[3] := X2;
      C[4] := Y2 - Y;
    end else begin
      C[1] := X1;
      C[2] := Y1 - Y;
      C[3] := X2 + W;
      C[4] := Y2;
    end;
  end;

  for I := 1 to 6 do begin
    Result := Result + Format(' %6.1f', [C[I]]) + ' ';
  end;
  Result := trim(Result) + ' c';
end;


end.