qrxmlsfilt.pas

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

end;
function ColTrans( ct : TColor ) : string;
var
   tempstr : string;
begin
    if ct < 0 then
    begin
        ct := ct and $FFFFFF;
    end;
    tempstr := format ( '%6.6x', [longint(ct)]);
    result := '#' + copy( tempstr, 5, 2 ) +copy( tempstr, 3, 2 )  +copy( tempstr, 1, 2 ) ;
end;

// places a blank document in the stringlist
procedure TQRXDocumentFilter.NewDocument( doclist : TStringlist; PaperWidth, PaperHeight : double;
              Papername, orient : string);
begin
//Title*, DocType*, Creator*, Author*, Date*, Copyright*, Orientation*
    LoadDTD( doclist );
    doclist.Add( '<QXDocument>' + CRLF );
    doclist.Add( '<Header Pagewidth="'+format( '%6.2f', [PaperWidth])+
                      '" Pageheight="'+format( '%6.2f', [Paperheight])
                      +'" PaperName="A4" Units="mm">' );
    doclist.Add( '   <Title>'+EntityReplace(FTitle)+'</Title>' );
    doclist.Add( '   <DocType>'+EntityReplace(FDocType)+'</DocType>' );
    doclist.Add( '   <Creator>'+EntityReplace(FCreator)+'</Creator>' );
    doclist.Add( '   <Author>'+EntityReplace(FAuthor)+'</Author>'  );
    doclist.Add( '   <Date>'+EntityReplace(FDocDate)+'</Date>' );
    doclist.Add( '   <Copyright>'+EntityReplace(FCopyright)+'</Copyright>'  );
    doclist.Add( '   <Orientation>'+EntityReplace(FOrientation)+'</Orientation>' );
    doclist.Add( '</Header>'  );
    doclist.Add( '</QXDocument>' );
end;

// Overridden Start
procedure TQRXDocumentFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
var
    dlist : TStringlist;
    k : integer;
begin
    inherited;  // creates a stream
    // output the dtd now because the data will stream out
    dlist := TStringlist.create;
    LoadDTD( dlist );
    for k := 0 to dlist.count-1 do
        writetostream( dlist[k]+CRLF);
    writetostream( '<QXDocument>' + CRLF );
    writetostream( '<Header Pagewidth="'+format( '%6.2f', [PaperWidth*0.1])+
                      '" Pageheight="'+format( '%6.2f', [Paperheight*0.1])+'" PaperName="A4" Units="mm">' + CRLF );
    writetostream( '   <Title>'+EntityReplace(FTitle)+'</Title>' + CRLF );
    writetostream( '   <DocType>'+EntityReplace(FDocType)+'</DocType>' + CRLF );
    writetostream( '   <Creator>'+EntityReplace(FCreator)+'</Creator>' + CRLF );
    writetostream( '   <Author>'+EntityReplace(FAuthor)+'</Author>' + CRLF );
    writetostream( '   <Date>'+EntityReplace(FDocDate)+'</Date>' + CRLF );
    writetostream( '   <Copyright>'+EntityReplace(FCopyright)+'</Copyright>' + CRLF );
    writetostream( '   <Orientation>'+EntityReplace(FOrientation)+'</Orientation>' + CRLF );
    writetostream( '</Header>' + CRLF );
end;

// overridden Finish
procedure TQRXDocumentFilter.Finish;
begin
    if fconcatenating then exit;
    writetostream( '</Page>'+CRLF);
    writetostream( '</QXDocument>' + CRLF );
    inherited;
end;

procedure TQRXDocumentFilter.EndConcat;
begin
     fconcatenating := false;
     Finish;
end;

procedure TQRXDocumentFilter.TextOut(X, Y : extended; Font : TFont; BGColor : TColor;
               Alignment : TAlignment; Text : string);
var
  I  : integer;
  parentrep : TQuickrep;
  ctext,fbold, fitalic, funderline, fstrike : string;
  textlen, Xmm, Ymm : double;
  xp : integer;
begin
    //
    parentrep := tquickrep( self.owner );
    // catch the current record
    fBold := 'normal';
    fitalic := 'none';
    funderline := 'none';
    Xmm := LeftMarginAdjust + (X/10.0);
    Ymm := Y/10.0;
    // deal with alignment
    if (Alignment = taRightJustify) and true then
    begin
         // mm/10 to pixels
         xp := parentrep.QRPrinter.XPos( X );
         parentrep.QRPrinter.Canvas.font := font;
         textlen := parentrep.QRPrinter.Canvas.TextWidth( trim(text) );
         xp := round(xp-textlen);
         // pixels to mm
         Xmm := 0.1 * xp / parentrep.QRPrinter.xfactor;
    end
    else if Alignment = taCenter then
    begin
         xp := parentrep.QRPrinter.XPos( X );
         parentrep.QRPrinter.Canvas.font := font;
         textlen := parentrep.QRPrinter.Canvas.TextWidth( trim(text) );
         xp := round(xp-(textlen/2.0));
         // pixels to mm
         Xmm := 0.1 * xp / parentrep.QRPrinter.xfactor;
    end;

    if fsBold in Font.Style then fbold := 'Bold';
    if fsItalic in Font.Style then fitalic := 'Italic';
    if fsUnderline in Font.Style then funderline := 'Underline';
    if fsStrikeout in Font.Style then fstrike := 'Strikeout';
    i := font.size;
    ctext := format('<Item Type="Text" Layer="0" Font="%-s" XPos="%-4.2f" YPos="%-4.2f" Height="%-d" Color="%-s" Weight="%s" Decoration="%-s">',
                    [ font.name, Xmm, Ymm, i, coltrans(font.color),fbold, fitalic ]);
    writetostream( ctext);
    ctext := text;
    writetostream( EntityReplace(ctext) );
    writetostream( '</Item>' + CRLF );
    FLastRecordNum := parentrep.DataSet.RecNo;
end;

// turns a byte into 2 hex digits
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 TQRXDocumentFilter.AcceptGraphic( Xoff, Yoff : extended; GControl : TControl);
const
     REC_SIZE = 2048;
var
    conwidth, conheight, coffset : integer;
    ctext : string;
    tempmap : TBitmap;
    SSCont : TQRShape;
    qrdbcont : TQRDBImage;
    drawpict : TPicture;
    istream, rlestream : TMemoryStream;
    C1, C2 : char;
    cc : array[0..REC_SIZE] of byte;
    bytesin, i, ishape : integer;
    lineout, fill, layer : string;
    parentrep : TQuickrep;
    Xmm, Ymm, xscale, yscale, rectheight, rectwidth : double;
    xrescale, yrescale: double;
    imgbyref: boolean;
    imgurl: string;
begin
  parentrep := tquickrep( self.owner );
  tempmap := TBitmap.create;
  istream := TMemoryStream.Create;
  rlestream := TMemoryStream.create;
  drawpict := TPicture.Create;
  Xmm := LeftMarginAdjust + (25.4* Xoff / Screen.PixelsPerInch);
  Ymm := 25.4* Yoff / Screen.PixelsPerInch;
  try
     if( GControl is TQRShape ) then
     begin
         SSCont := (GControl as TQRShape);
         // apply adjust to all shapes. Frames are exported as rects
         Ymm := Ymm + VertLineAdjust;
         Xmm := Xmm + HorizLineAdjust;
         fill := 'Outline';
         layer := '1';
         if (sscont.Brush.Style <> bsClear) and ( sscont.shape=qrsRectangle) then
         begin
             layer := '2';
             fill := 'Fill';
         end;
         ishape := integer(sscont.Shape);
         // swap h and v lines to match QXD spec
         if ishape=2 then
           ishape := 3
         else if ishape = 3 then
           ishape := 2;
           // make sure the thing doesn't disappear.
         rectwidth := 25.4*sscont.width/ Screen.PixelsPerInch;
         if rectwidth < 0.5 then rectwidth := 0.5;
         rectheight := 25.4*sscont.height/ Screen.PixelsPerInch;
         if rectheight < 0.5 then rectheight := 0.5;
         ctext := format('<Item Type="Graphic" Layer="'+layer+'" XPos="%-4.2f" YPos="%-4.2f" Linewidth="%-4.2f" '+
                  'Shape="%-d" Width="%-4.2f" Height="%-4.2f" Color="%s" BackColor="%s" FillType="%s" >',
                    [  Xmm, Ymm, 25.4*sscont.pen.width / Screen.PixelsPerInch, ishape, rectwidth, rectheight,
                      coltrans(sscont.pen.color),coltrans(sscont.Brush.color), fill ]);
         writetostream( ctext);
         writetostream( 'Graphic item</Item>' + CRLF );
         exit;
    end;
    // It's a picture
    tempmap.width := GControl.Width;
    tempmap.height := GControl.height;
    xrescale := 1.0;
    yrescale := 1.0;
    conwidth := GControl.Width;
    conheight := Gcontrol.height;
    if (GControl is TQRImage) then
    begin
         if 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;
         xrescale := ((25.4*TQRImage(GControl).width/ Screen.PixelsPerInch) / tempmap.width);
         yrescale := ((25.4*TQRImage(GControl).height/ Screen.PixelsPerInch) / tempmap.height);
    end
    else if (GControl is TQRDBImage) then
    begin
       qrdbcont := GControl as TQRDBImage;
       if qrdbcont.field <> nil then
       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
          begin
               tempmap.assign( qrdbcont.field );
               conwidth := tempmap.Width;
               conheight := tempmap.height;
          end
          else
          begin
               tempmap.canvas.StretchDraw( Rect( 0, 0, tempmap.width, tempmap.height), drawpict.graphic);
          end;

          xrescale := ((25.4*qrdbcont.width/ Screen.PixelsPerInch) / tempmap.width);
          yrescale := ((25.4*qrdbcont.height/ Screen.PixelsPerInch) / tempmap.height);
       end;
    end;
    // stream out the ascii encoded picture data
    if FCompressImages then
         lineout := 'RLE'
    else
         lineout := 'None';

    xscale := 1.0 * conWidth / tempmap.Width * xrescale;
    yscale := 1.0 * conheight / tempmap.height * yrescale;

    imgbyref := false;
    imgurl := '';
    if Assigned(FOnImageURLNeeded) then
      FOnImageURLNeeded(Self,GControl,imgurl,imgbyref);

    if imgbyref then
      ctext := format('<Item Type="Image" XPos="%-4.2f" YPos="%-4.2f" Width="%-d" Height="%-d" Layer="1" Xscale ="%6.3f" Yscale ="%6.3f" Compression="'+lineout+'" ImageFile="%s">',
                      [ Xmm, Ymm, tempmap.width, tempmap.height, xscale, yscale, imgurl ])
    else
      ctext := format('<Item Type="Image" XPos="%-4.2f" YPos="%-4.2f" Width="%-d" Height="%-d" Layer="1" Xscale ="%6.3f" Yscale ="%6.3f" Compression="'+lineout+'">',
                      [ Xmm, Ymm, tempmap.width, tempmap.height, xscale, yscale ]);
    writetostream( ctext);
    
    if FDoImages and (not imgbyref) then
    begin
      if FCompressImages then
      begin
         tempmap.SaveToStream( rlestream );
         //tempmap.savetofile( 'tempmap.bmp'); // debug
         rlestream.Seek( 0, 0 );
         RunLength( rlestream, istream);
      end
      else
      begin
         tempmap.SaveToStream( istream );
         //tempmap.savetofile( 'tempmap.bmp');// debug
         istream.Seek( 0, 0 );
      end;
      bytesin := istream.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;
           writetostream( lineout+ CRLF );
           lineout := '';
           bytesin := istream.Read( cc, REC_SIZE );
      end;
    end;
    writetostream( '</Item>' + CRLF );

  finally
    tempmap.free;
    drawpict.free;
    istream.Free;
    rlestream.free;
  end;
end;

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

procedure TQRXDocumentFilter.NewPage;
begin
     if FPagenumber > 1 then  writetostream( '</Page>'+CRLF);
     writetostream( '<Page Number="'+inttostr( FPagenumber)+'">' + CRLF);
     inc(FPagenumber);
end;

// Standard run-length encoding code - translated from C
procedure RunLength(Source, Target: TStream);
var
  Buffer, C, LastOut, LastBuf: String;
  LastCnt, cn: 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.