qrpdffilt.pas

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

           qrsCircle: fpdfitem.shape := S_CIRCLE;
           qrsVertLine: fpdfitem.shape := S_VLINE;
           qrsHorLine: fpdfitem.shape := S_HLINE;
           qrsTopAndBottom: fpdfitem.shape := S_TOPBOTTOM;
           qrsRightAndLeft: fpdfitem.shape := S_LEFTRIGHT;
           qrsRoundrect : fpdfitem.shape := S_OBLIQUE;
         end;
         fpdfitem.Xpos := Xoff * PointsPerpixelX;
         fpdfitem.Ypos := Yoff * PointsPerpixelY;
         fpdfitem.thickness := SSCont.Pen.Width;
         if SSCont.Pen.Color< 0 then SSCont.Pen.Color := SSCont.Pen.Color and $00FFFFFF;
         fpdfitem.rgbstrokecolor.red := getRvalue( SSCont.Pen.Color);
         fpdfitem.rgbstrokecolor.green := getGvalue( SSCont.Pen.Color);
         fpdfitem.rgbstrokecolor.blue := getBvalue( SSCont.Pen.Color);
         fpdfitem.rgbfcolor.red := getRvalue( SSCont.brush.Color);
         fpdfitem.rgbfcolor.green := getGvalue( SSCont.brush.Color);
         fpdfitem.rgbfcolor.blue := getBvalue( SSCont.brush.Color);
         fpdfitem.width := SSCont.Width * PointsPerpixelX;
         fpdfitem.height := SSCont.height * PointsPerpixelX;
         fpdfitem.filled := bsClear <> SSCont.Brush.Style;
         fpdfitem.Fontname := nil;
         fpdfitem.FText := nil;
         addpdfitem( fpdfitem );
         exit;
    end;
    //-------------------------------------------------------
    // It's a picture
    tempmap.width := GControl.Width;
    tempmap.height := GControl.height;
    conwidth := GControl.Width;
    conheight := Gcontrol.height;
    fpdfitem.imagestring := '';
    if (GControl is TQRGrImage) then
    begin
         if not TQRGrImage(GControl).ClipImage then
             tempmap.canvas.stretchdraw( Rect( 0, 0, tempmap.width, tempmap.height),
                                             TQRGrImage(GControl).Picture.graphic)
         else
         begin
             tempmap.canvas.draw(  0, 0, TQRGrImage(GControl).Picture.graphic)
         end;
         CaptureImageBytes( tempmap, fpdfitem.imagestring );
    end
    else if (GControl is TQRImage) then
    begin
         if not TQRImage(GControl).stretch then
             tempmap.canvas.stretchdraw( Rect( 0, 0, tempmap.width, tempmap.height),
                                             TQRImage(GControl).Picture.graphic)
         else
         begin
             tempmap.canvas.draw(  0, 0, TQRImage(GControl).Picture.graphic)
         end;
         CaptureImageBytes( tempmap, fpdfitem.imagestring );
    end
    else if (GControl is TQRDBImage) then
    begin
       qrdbcont := GControl as TQRDBImage;
       if qrdbcont.field = nil then
          exit
       else
       begin
          drawpict.Assign( qrdbcont.field );
          //AspectRatio := 1.0 * drawpict.Width / drawpict.height;
          if not qrdbcont.Stretch then
          begin
              // the picture shrinks or grows to fit the control
              // this tiresome code is a mirror of that in the DBImage print
              if (drawpict.Width/conwidth) < (drawpict.Height/conHeight) then
              begin
                  // the height ratio is greater so shrink the width and center horiz
                  coffset := conwidth; // save the current width
                  conwidth := round(drawpict.width/(drawpict.Height/conHeight));
                  coffset := ( coffset - conwidth) div 2;
                  Xoff :=Xoff + coffset;
              end
              else
              begin
                  coffset := conheight;
                  conheight := round(drawpict.Height/(drawpict.Width/conwidth));
                  coffset := ( coffset - conheight) div 2;
                  Yoff := Yoff + coffset;
              end;
          end;
          //--------
          if qrdbcont.stretch then
               tempmap.assign( qrdbcont.field )
          else
          begin
                  tempmap.canvas.draw(  0, 0, drawpict.graphic);
          end;
          CaptureImageBytes( tempmap, fpdfitem.imagestring );
       end;
    end
    else if (GControl is TQRGrDBImage) then
    begin
       dbcont := GControl as TQRGrDBImage;
       if dbcont.field = nil then
           exit
       else
       begin
          drawpict.Assign( dbcont.field );
          AspectRatio := 1.0 * drawpict.Width / drawpict.height;
          if not dbcont.Stretch then
          begin
               if dbcont.FitMode=fmInsideProp then
               begin
                 // the picture shrinks or grows to fit the control
                 // this tiresome code is a mirror of that in the DBImage print
                 if (drawpict.Width/conwidth) < (drawpict.Height/conHeight) then
                 begin
                  // the height ratio is greater so shrink the width and center horiz
                  coffset := conwidth; // save the current width
                  conwidth := round(drawpict.width/(drawpict.Height/conHeight));
                  coffset := ( coffset - conwidth) div 2;
                  Xoff :=Xoff + coffset;
                 end
                 else
                 begin
                  coffset := conheight;
                  conheight := round(drawpict.Height/(drawpict.Width/conwidth));
                  coffset := ( coffset - conheight) div 2;
                  Yoff := Yoff + coffset;
                 end;
               end
               else if dbcont.FitMode=fmProportional then
               begin
                  if (drawpict.Width/conwidth) < (drawpict.Height/conHeight) then
                     conHeight := trunc( conwidth / aspectratio )
                  else
                     conwidth := trunc( conheight * aspectratio );
               end
               else if dbcont.FitMode=fmKeepWidth then
                   conHeight := trunc( conwidth / aspectratio )
               else if dbcont.FitMode=fmKeepHeight then
                   conwidth := trunc( conheight * aspectratio );
          end;
          //--------
          if not dbcont.ClipImage then
               tempmap.assign( dbcont.field )
          else
          begin
                  tempmap.canvas.draw(  0, 0, drawpict.graphic);
          end;
          CaptureImageBytes( tempmap, fpdfitem.imagestring );
       end;
    end;
    if (Tempmap.Width < 1) or (Tempmap.Height < 1) then exit; // through 'finally'                                                      
    fpdfitem.ItemType := IT_IMAGE;
    //fpdfitem.imagesrc := allocmem( length(imgfilename ) + 1 );
    //strpcopy( fpdfitem.imagesrc, imgfilename );
    fpdfitem.Xpos := Xoff * PointsPerpixelX;
    fpdfitem.Ypos := (conheight + Yoff) * PointsperpixelY;
    fpdfitem.width := tempmap.Width * PointsPerpixelX;
    fpdfitem.height := tempmap.height * PointsPerpixelX;
    fpdfitem.pixelwidth := tempmap.Width;
    fpdfitem.pixelheight := tempmap.height;
    fpdfitem.xscale := 1.0 * conWidth / tempmap.Width;
    fpdfitem.yscale := 1.0 * conheight / tempmap.height;
    AddImageItem( fpdfitem, nil );
  finally
    tempmap.free;
    drawpict.free;
  end;
end;
{
    BitBuff : array of byte; // address of array for bitmap bits
    bminf : PBitmapInfo;     // address of structure with bitmap data
GetDIBits( (GControl as TQRImage).canvas.handle,
        (GControl as TQRImage).Picture.bitmap.handle,
        0, 0, nil, bminf, DIB_RGB_COLORS );
}

procedure TQRPDFDocumentFilter.EndPage;
begin
    // do nothing
end;

// Override method
procedure TQRPDFDocumentFilter.NewPage;
begin
    // add a newpage item
    if FFirstPage then
    begin
        FFirstPage := false;
        exit;
    end;
    FPDFItem.ItemType := IT_NEWPAGE;
    AddPDFItem( FPDFItem );
    inc(FPageNumber);
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;

procedure AsciiHexToString(Source: TStream; var outstr : string);
const
     REC_SIZE = 2048;
     CRLF = chr($0D) + chr($0A);
var
    C1, C2 : char;
    cc : array[0..REC_SIZE] of byte;
    bytesin : longint;
    lineout : string;
    i : integer;
begin
    source.Seek( 0, 0 );
    bytesin := Source.Read( cc, REC_SIZE );
    lineout := '';
    while( bytesin > 0 ) do
    begin
         for i := 0 to bytesin-1 do
         begin
            Hexit( C1, C2, cc[i] );
            lineout := lineout +C1+C2;
         end;
         outstr := outstr + lineout;
         lineout := '';
         bytesin := Source.Read( cc, REC_SIZE );
    end;
end;

procedure AsciiHex(Source: TStream; imgfilename : string);
const
     REC_SIZE = 2048;
     CRLF = chr($0D) + chr($0A);
var
    C1, C2 : char;
    cc : array[0..REC_SIZE] of byte;
    bytesin : longint;
    lineout : string;
    i : integer;
    imgfile : TextFile;
begin
    assignfile( imgfile, imgfilename);
    rewrite( imgfile );
    source.Seek( 0, 0 );
    bytesin := Source.Read( cc, REC_SIZE );
    lineout := '';
    while( bytesin > 0 ) do
    begin
         for i := 0 to bytesin-1 do
         begin
            Hexit( C1, C2, cc[i] );
            lineout := lineout +C1+C2;
         end;
         writeln( imgfile, lineout );
         lineout := '';
         bytesin := Source.Read( cc, REC_SIZE );
    end;
    closefile( imgfile);
end;

// Standard run-length encoding code - translated from C
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;

end.