qrexport.pas

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

  // page settings for the report.
  if aReport = nil then
  begin
    // Set the default margins of for some reason we don't have the
    // owner property set correctly
    aTop := 720;
    aBottom := 720;
    aLeft := 720;
    aRight := 720;
    aLength := 0;
    aWidth := 0;
    IsLandScape := false;
  end
  else
  begin
    with aReport do
    begin
      // Save the current units
      aUnit := Units;

      // Set the units to Inches to make it easy to convert margins
      // to twips
      Units := Inches;

      aLength := Page.Length * 1440;
      aWidth := Page.Width * 1440;
      aTop := Page.TopMargin * 1440;
      aBottom := Page.BottomMargin * 1440;
      aLeft := Page.LeftMargin * 1440;
      aRight := Page.RightMargin * 1440;

      IsLandScape := Page.Orientation = poLandscape;

      // restore the units - may not be needed
      Units := aUnit;
    end;
  end;

  GetAllFonts;
  AssignFile(aFile, Filename);
  Rewrite(aFile);

  // Make sure that the frst page doesn't start with a pagebreak
  PendingPageBreak := False;

  // Best guess approximation of the number of lines on a page
  YFactor := Font.Size * (254 / 72);

  // CJM: We raised the line count to fix a problem when the user
  // used smaller fonts than the report's main font.
  YFactor := (254 / 72);

  XFactor := Font.Size * (254 / 72);
  LineCount := round(PaperHeight / YFactor);

  Header := '{\rtf1';  // RTF version - do not change
  Header := Header +'\ansi';  // Character set
  Header := Header +'\deff0';
  Header := Header +'\deftab720'; // Default tab width in twips (the default is 720)

  // Set the paper size
  if aLength > 0 then begin
    Header := Header + '\paperh' + IntToStr(round(aLength)); // Set page length
    Header := Header + '\paperw' + IntToStr(round(aWidth));  // Set page width
    Header := Header + '\psz' + IntToStr(integer(aReport.PrinterSettings.PaperSize));  // Set paper size
  end;


  Header := Header + '\margl' + IntToStr(round(aLeft));  // Set the left margin
  Header := Header + '\margr' + IntToStr(round(aRight));  // Set the right margin
  Header := Header + '\margt' + IntToStr(round(aTop));  // Set the top margin
  Header := Header + '\margb' + IntToStr(round(aBottom));  // Set the bottom margin

  if IsLandScape then
    Header := header + '\landscape';

  // Since the programmer can change the fonts at runtime, the fastest
  // way to build a list of fons that can be used is to store a list
  // in memory of all of the fonts in the system
  FontTable := '{\fonttbl';
  for i := 0 to RTFFontList.Count -1 do
  begin
    FontTable := FontTable + '{\f' + IntToStr(I) +
      QRRTFFontFamily[Integer(RTFFontList.Objects[I])] +
      ' ' + RTFFontList[I] + ';}';  // Font #, name
  end;
  FontTable := FontTable + '}';  // End of font table definition;

  // Build a color table from the usual Delphi defines
  ColorTable := '{\colortbl';
  for i := low(QRRTFColors) to high(QRRTFColors) do
    ColorTable := ColorTable + ColorToRTFColor(QRRTFColors[i]);
  ColorTable := ColorTable + '}';

  DefaultLanguage := '\deflang1033'; // English

  ResetPar := '\pard\plain'; // default paragraph, default fonts
  NewPar := '\par ';

  Writeln(aFile, Header + FontTable);
  Writeln(aFile, ColorTable);
  Writeln(aFile, DefaultLanguage);
end;

procedure TQRRTFExportFilter.EndPage;
var
  I, j : integer;
  twipx, twipy, MaxFontY : integer;
  LastY: extended;
  TabStops, s, row: string;
  aQRRTFItem: TQRRTFItem;
begin
  // On pages after the 1st page, output the pagebreak tag for
  // the preceding page
  if PendingPageBreak then
    Writeln(aFile, '{\page }');

  // We go through each line and generate the RTF code to format it.
  // The export filter code will call EndPage before the first page
  // so we make sure that RTFLines is assigned (in NewPage) before
  // processing the data
  if Assigned(RTFLines) then
  begin
    LastY := aTop * (254.0/1440.0);
    MaxFontY := 0;
    for I := 0 to RTFLines.Count -1 do
    begin
      s := '{\plain';
      TabStops := '';
      row := '';
      with TQRRTFLineItem(RTFLines[I]) do
      begin
        // Get each field from the current line
        for j := 0 to RTFItems.Count-1 do
        begin
          aQRRTFItem := TQRRTFItem(RTFItems[j]);

          // Calculate how far down this line is from the previous
          // line.  We only need to do this once per line
          if TabStops = '' then begin
            TabStops := '\pard\plain';
            TwipY := round((aQRRTFItem.y - LastY) * (1440.0/254.0)) -
              (MaxFontY * 10) - RTF_VertAdj;
            // If vertical spacing is required, add it to the line
            // This may not display correctly in WordPad or in the TRichEdit
            // control
            if TwipY > 0 then
              TabStops := TabStops + '\sb' + IntToStr(TwipY);
          end;

          // Store the largest font size
          if aQRRTFItem.FontSize > MaxFontY then
            MaxFontY := aQRRTFItem.FontSize;

          // Store the highest Y value for this line
          if aQRRTFItem.y > LastY then
            LastY := aQRRTFItem.y;

          // Convert the quickreport coordinates to
          // twips.  Each QR unit is 1/254 of an inch
          // and there 1440 twips to an inch
          // We subtract the left margin to get the correct tab stop.
          // RTF does not like a tab stop of 0, so we add 20 to keep
          // the formatting intact.
          twipx := round((aQRRTFItem.x * (1440.0/254.0)) - aLeft) + 20;

          // Set the alignment.  Please note that this tag is
          // ignored by the RichEdit common control and will
          // not be used by WordPad or the Delphi/C++Builder RTF
          // controls.
          case aQRRTFItem.Alignment of
            taLeftJustify: TabStops := TabStops + '\tql';
            taRightJustify: TabStops := TabStops + '\tqr';
            taCenter: TabStops := TabStops + '\tqc';
          end;

          // Set the positions of each item on this line
          TabStops := TabStops + '\tx' + IntToStr(twipx);

          // Output each item starting with the tab
          // We include the \plain tag so that attributes
          // will be reset for each field
          row := row + '\tab\plain';

          // If we know the font (we should), we specify it now.
          if aQRRTFItem.RTFFont >= 0 then
            row := row + '\f' + IntToStr(aQRRTFItem.RTFFont);

          // Set the font size
          row := row + '\fs' +  IntToStr(aQRRTFItem.FontSize);

          // set the font style(s)
          if fsBold in aQRRTFItem.FontStyle then row := row + '\b';
          if fsItalic in aQRRTFItem.FontStyle then row := row + '\i';
          if fsUnderline in aQRRTFItem.FontStyle then row := row + '\ul';
          if fsStrikeOut in aQRRTFItem.FontStyle then row := row + '\strike';


          // Get the color tag for the font
          row := row + RTFColorTag(aQRRTFItem.FontColor);

          // finally output the text
          row := row + ' ' + aQRRTFItem.Text;
        end;
//        s := s + row + ' {\par}}';
        // fix:  Need code to determine location of next line on
        // page so we can space the lines closer to how the report
        // looks
        s := s + row + '{\fs1\par}}';
      end;
      if row <> '' then
      begin
        // write the tabstops for this line
        Writeln(aFile, TabStops);
        // write the fields
        Writeln(aFile, s);
        // Set the flag so that we know that new page will generate a page break
        PendingPageBreak := True;
      end;
    end;
  end;
end;

procedure TQRRTFExportFilter.Finish;
begin
  // write the closing part of the RTF formatting
  Writeln(aFile, '\par }');

  // All done, close the file
  CloseFile(aFile);

  // free the allocated memory
  DestroyRTFLines;
end;

procedure TQRRTFExportFilter.DestroyRTFLines;
var
 aQRRtfLineItem : TQRRtfLineItem;
begin
  if assigned(RTFLines) then // check to see if it's already created
  begin
    while RTFLines.Count > 0 do
    begin
      if RTFLines[RTFLines.Count-1] <> nil then
      begin
        aQRRtfLineItem := TQRRtfLineItem(RTFLines[RTFLines.Count-1]); // for faster access
        RTFLines[RTFLines.Count-1] := nil; // remove from list
        aQRRtfLineItem.ClearLineItems; // clear the embedded items.
        aQRRtfLineItem.Free; // and clear the TQrRtfLineItem;
      end;
      RTFLines.Delete(RTFLines.Count-1); // and finally remove it
    end;
    RTFLines.Free;
    RTFLines := nil;
  end;
end;

procedure TQRRTFExportFilter.CreateRTFLines;
var
  I : integer;
begin
  DestroyRTFLines; // if already there remove it.
  RTFLines := TList.Create; // create a new one
  for I := 0 to LineCount - 1 do // and fill it up
    RTFLines.Add(TQRRTFLineItem.Create);
end;

procedure TQRRTFExportFilter.NewPage;
begin
  // Initialize the buffer
  CreateRTFLines;
end;

procedure TQRRTFExportFilter.TextOut(X, Y : Extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string);
var
  aQRRTFItem: TQRRTFItem;
  function RTFSafeText(const str: string): string;
  var ll: integer;
  begin
    result := '';
    for ll := 1 to length(str) do begin
      if (str[ll] = '\') or (str[ll] = '}') or (str[ll] = '{') then
        result := result + '\';
      result := result + str[ll];
    end;
  end;
begin
  // Create a new field item and set it's properties
  aQRRTFItem := TQRRTFItem.Create;
  aQRRTFItem.x := x;
  aQRRTFItem.y := y;
  aQRRTFItem.Text := RTFSafeText(Text);
  aQRRTFItem.Alignment := Alignment;
  aQRRTFItem.RTFFont := RTFFontList.IndexOf(Font.Name);
  aQRRTFItem.FontColor := Font.Color;
  aQRRTFItem.FontStyle := Font.Style;

  // RTF font size is measured in 1/2 points, so we need to
  // double the size value
  aQRRTFItem.FontSize := Font.Size shl 1;

  // Get an approximate guess to where the line is in the list
  Y := Y / YFactor;

  // Add this field to list of fields for the current line
  // Added check to ignore controls that are below the printable
  // page area
  if round(y) < RTFLines.Count then
    TQRRTFLineItem(RTFLines[round(y)]).Add(aQRRTFItem)
end;

constructor TQRRTFFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRRTFExportFilter);
end;

destructor TQRRTFFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRRTFExportFilter);
  inherited Destroy;
end;

function TQRWMFExportFilter.GetDescription : string;
begin
  result := SqrWMFExportFilter;
end;

function TQRWMFExportFilter.GetFilterName : string;
begin
  result := SqrWMFFile;
end;

function TQRWMFExportFilter.GetExtension : string;
begin
  result := 'WMF'; // Do not locallize
end;

procedure TQRWMFExportFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
var
  i: integer;
begin
  // If the user specifies a file extension, we get rid of it.
  aBase := filename;
  i := length(aBase);

  while i > 0 do
  begin
    if aBase[i] = '.' then
    begin
      aBase := copy(aBase, 1, i-1);
      break;
    end;
    dec(i);
  end;
end;

procedure TQRWMFExportFilter.EndPage;
begin
  // Stub code for filter
end;

procedure TQRWMFExportFilter.Finish;
var
  i: integer;
  aMetaFile: TMetaFile;
begin
  if Owner is TCustomQuickRep then
  begin
    with TCustomQuickRep(Owner) do
    begin
      if OriginalQRPrinter <> nil then
      begin
        with OriginalQRPrinter do
        begin
          // Get each page and save it as a metafile
          // At this point in time, the PageList.PageCount
          // has not been set.  We'll force it here
          for i := 1 to PageNumber do
          begin
            // Retrieve the current page as a metafile
            aMetaFile := GetPage(i);

            if Assigned(aMetaFile) then
            begin
              aMetaFile.Enhanced := WMF_Enhanced;
              if aMetaFile.Enhanced then
                aMetaFile.SaveToFile(aBase + format('%3.3d', [i]) + '.emf')
              else
                aMetaFile.SaveToFile(aBase + format('%3.3d', [i]) + '.wmf');

              aMetaFile.Free;
            end;
          end;
        end;
      end;
    end
  end;
end;

procedure TQRWMFExportFilter.NewPage;
begin
  // Stub code for filter
end;

procedure TQRWMFExportFilter.TextOut(X, Y : Extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string);
begin
  // Stub code for filter
end;

constructor TQRWMFFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  WMF_Enhanced := False;
  QRExportFilterLibrary.AddFilter(TQRWMFExportFilter);
end;

destructor TQRWMFFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRWMFExportFilter);
  inherited Destroy;
end;

function TQRWMFFilter.GetEnhanced : boolean;
begin
  Result := WMF_Enhanced;
end;

procedure TQRWMFFilter.SetEnhanced(Value : boolean);
begin
  WMF_Enhanced := Value;
end;


{$endif}

{ TQRAsciiExportFilter }

function dup(aChar : Char; Count : integer) : string;
var
  I : integer;
begin
  result := '';
  for I := 1 to Count do result := result + aChar;
end;

function TQRAsciiExportFilter.GetDescription : string;
begin
  result := SqrAsciiFilterDescription;
end;

function TQRAsciiExportFilter.GetFilterName : string;
begin
  result := SqrAsciiFilterName;
end;

function TQRAsciiExportFilter.GetExtension : string;
begin
  result := SQrAsciiFilterExtension;
end;

procedure TQRAsciiExportFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
begin
  AssignFile(aFile, Filename);
  Rewrite(aFile);
  YFactor := Font.Size * (254 / 72);
  XFactor := Font.Size * (254 / 72);
  LineCount:=round(PaperHeight / YFactor);
end;

procedure TQRAsciiExportFilter.EndPage;
var
  I : integer;
begin
  for I := 0 to LineCount - 1 do
    if length(Lines[I]) > 0 then Writeln(aFile, Lines[I]);
end;

procedure TQRAsciiExportFilter.Finish;
begin
  CloseFile(aFile);
end;

procedure TQRAsciiExportFilter.NewPage;
var
  I : integer;
begin
  for I := 0 to 200 do
    Lines[I] := '';
end;

procedure TQRAsciiExportFilter.TextOut(X, Y : Extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string);
var
  aLine : string;
begin
  X := X / XFactor * 1.7;
  Y := Y / YFactor;
  if Alignment=taRightJustify then
    X := X - Length(Text);
  aLine := Lines[round(Y)];
  if length(aLine) < X then
    aLine:=aLine + dup(' ', round(X) - length(aLine));
  Delete(aLine, round(X), Length(Text));
  Insert(Text, aLine, round(X));
  Lines[trunc(Y+0.5)] := aLine;
end;

constructor TQRTextFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRAsciiExportFilter);
end;

destructor TQRTextFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRAsciiExportFilter);
  inherited Destroy;
end;

{$ifndef QRSTANDARD}
initialization
  RTFFontList := TStringList.Create;
  RTF_VertAdj := 50;
  {$ifdef DELPHI6}
  GroupDescendentsWith(TQRCSVFilter, TControl);
  GroupDescendentsWith(TQRTextFilter, TControl);
  {$endif}
finalization
  RTFFontList.Free;
{$endif}

end.