qrexport.pas

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

{ :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  :: QuickReport 4.0 for Delphi and C++Builder               ::
  ::                                                         ::
  :: QREXPORT.PAS - EXPORT FILTERS                           ::
  ::                                                         ::
  :: Copyright (c) 2001 2001 A Lochert                       ::
  :: All Rights Reserved                                     ::
  ::                                                         ::
  :: web: http://www.qusofcom                                ::
  :: QR4 - Removed old HTML code                             ::
  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: }

{$I QRDEFS.INC}
unit QRExport;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, QRPrntr,
  QuickRpt, Db, StdCtrls, QRCtrls, QR4Const, Printers, forms;

type
  TTextEntry = class(TPersistent)
  private
    FText : string;
    XPos, YPos : extended;
    FAlignment : TAlignment;
    TextFont : TFont;
  end;

  TQRAbstractExportFilter = class(TQRExportFilter)
  private
    Entries : TList;
    FStream : TStream;
    FCharWidth,
    FCharHeight,
    FPaperWidth,
    FPaperHeight : extended;
    FLineCount,
    FColCount : integer;
    FPageProcessed : boolean;
    FFont : TFont;
    FActiveFont : TFont;
  protected
    function GetText(X, Y : extended; var Font : TFont) : string;
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
    procedure WriteToStream(const AText : string);
    procedure WriteLnToStream(const AText : string);
    procedure CreateStream(Filename : string); virtual;
    procedure CloseStream; virtual;
    procedure ClearEntries;
    procedure ProcessPage; virtual;
    procedure ConvertToColumns;
    procedure ConvertToLines;
    procedure StorePage; virtual;
    property Stream : TStream read FStream write FStream;
    property PageProcessed : boolean read FPageProcessed write FPageProcessed;
    property CharWidth : extended read FCharWidth write FCharWidth;
    property CharHeight : extended read FCharHeight write FCharHeight;
    property PaperWidth : extended read FPaperWidth write FPaperWidth;
    property PaperHeight : extended read FPaperHeight write FPaperHeight;
    property LineCount : integer read FLineCount write FLineCount;
    property ColCount : integer read FColCount write FColCount;
  public
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure EndPage; override;
    procedure Finish; override;
    procedure NewPage; override;
    procedure AcceptGraphic( Xoff, Yoff : extended; GControl : TControl); override;
    procedure TextOut(X, Y : extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string); override;
  end;

  TQRCommaSeparatedFilter = class(TQRAbstractExportFilter)
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
  public
    procedure StorePage; override;
  end;

  TQRCSVFilter = class(TComponent)
  protected
    function GetSeparator : char;
    procedure SetSeparator(Value : char);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property Separator : char read GetSeparator write SetSeparator;
  end;

{$ifndef QRSTANDARD}
  TCellType = (CellBlank, CellInteger, CellDouble, CellLabel, CellBoolean);

  TQRXLSFilter = class(TQRAbstractExportFilter)
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
    function GetStreaming : boolean; override;
    procedure CreateStream(Filename : string); override;
    procedure CloseStream; override;
    procedure WriteRecordHeader(RecType, Size : integer);
    procedure WriteData(CellType : TCellType; ARow, ACol: Integer; Cell : string); virtual;
  private
    FReportNum : integer;
  public
    Concatenating : boolean;
    procedure StorePage; override;
    procedure EndConcat;
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure Finish; override;
  end;

  TQRExcelFilter = class(TComponent)
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  end;

const
  // This a lookup table of the Delphi defined colors
  QRRTFColors: array[0..17] of TColor =
    (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal,
    clGray, clSilver, clRed, clLime, clYellow, clBlue, clFuchsia,
    clAqua, clLtGray, clDkGray, clWhite);

  // We define a quick lookup table of the RTF font family control
  // words.  Windows only supports items 0-5, the last two are defined
  // by Microsoft but are not used in the LOGFONT structure
  QRRTFFontFamily: array[0..7] of string =
   ('\fnil', '\froman', '\fswiss', '\fmodern', '\fscript', '\fdecor',
    '\ftech', '\fbidi');

type
  // The TQRRTFItem class defines an object that represents a field
  // from the report.  Multiple line fields will generate an TQRRTFItem
  // for each line.

  TQRRTFItem = class
    FontColor: TColor;
    FontStyle: TFontStyles;
    FontSize: integer;
    RTFFont: integer;
    x,y: extended;
    Alignment: TAlignment;
    Text: string;
  end;

  // the TQRRTFLineItem class is a container of TQRRTFItem objects.
  // It is basicly a list of fields for a line from the report

  TQRRTFLineItem = class
    RTFItems: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ClearLineItems;
    procedure Add(value: TQRRTFItem);
  end;

  TQRRTFExportFilter = class(TQRExportFilter)
  private
    LineCount : integer;
    RTFLines: TList;
    aFile : text;
    XFactor,
    YFactor : extended;

    Header,
    FontTable,
    ColorTable,
    DefaultLanguage,
    NewPar,
    ResetPar : string;
    PendingPageBreak: boolean;
    aTop, aBottom, aLeft, aRight, aLength, aWidth: extended;
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
    procedure CreateRTFLines;
    procedure DestroyRTFLines;
  public
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure EndPage; override;
    procedure Finish; override;
    procedure NewPage; override;
    procedure TextOut(X,Y : extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string); override;
  end;

  TQRRTFFilter = class(TComponent)
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  end;

  TQRWMFExportFilter = class(TQRExportFilter)
  private
    aBase: string;
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
  public
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure EndPage; override;
    procedure Finish; override;
    procedure NewPage; override;
    procedure TextOut(X,Y : extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string); override;
  end;

  TQRWMFFilter = class(TComponent)
  protected
    function GetEnhanced : boolean;
    procedure SetEnhanced(Value : boolean);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property Enhanced : boolean read GetEnhanced write SetEnhanced;
  end;

{$endif}

  { TQRAsciiExportFilter }
  TQRAsciiExportFilter = class(TQRExportFilter)
  private
    LineCount : integer;
    Lines : array[0..200] of string;
    aFile : text;
    XFactor,
    YFactor : extended;
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
  public
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure EndPage; override;
    procedure Finish; override;
    procedure NewPage; override;
    procedure TextOut(X,Y : extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string); override;
  end;

  TQRTextFilter = class(TComponent)
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  end;

implementation

uses qrexpr;

type
  TQRPositions = class
  private
    List : TList;
    Updating : boolean;
    IgnoreClientCount : boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure Add(Position : extended);
    function NewPosition(Position : extended) : integer;
  end;

  TQRPositionEntry = class
  private
    ExactPosition : extended;
    NewPosition : integer;
    Clients : integer;
    Stored : boolean;
  public
    constructor Create(Position : extended);
  end;

var
  CSV_Separator : char;
  WMF_Enhanced : boolean;
  RTF_VertAdj: integer;

function ColorToHTMLColor(Color : TColor) : string;
begin
  Result := IntToHex(Color, 6);
  Result := copy(Result, 5,2) + copy(result, 3, 2) + copy(Result, 1, 2);
end;

constructor TQRPositionEntry.Create(Position : extended);
begin
  NewPosition := 0;
  Clients := 1;
  ExactPosition := Position;
  Stored := False;
end;

constructor TQRPositions.Create;
begin
  List := TList.Create;
  Updating := False;
  IgnoreClientCount := False;
end;

destructor TQRPositions.Destroy;
begin
  while List.Count > 0 do
  begin
    TQRPositionEntry(List[0]).Free;
    List.Delete(0);
  end;
  List.Free;
  inherited Destroy;
end;

procedure TQRPositions.BeginUpdate;
begin
  Updating := True;
end;

procedure TQRPositions.EndUpdate;
var
  I, J : integer;
  Min : extended;
  No : integer;
begin
  Updating := False;
  No := 0;
  for I := 0 to List.Count - 1 do
  begin
    Min := 9999999;
    for J := 0 to List.Count - 1 do
      with TQRPositionEntry(List[J]) do
      begin
        if (ExactPosition > 0) and
           (ExactPosition < Min) and
//           ((Clients > 1) or (IgnoreClientCount)) and
           not Stored then
        begin
           Min := ExactPosition;
           No := J;
        end;
      end;
    with TQRPositionEntry(List[No]) do
    begin
      NewPosition := I + 1;
      Stored := True;
    end;
  end;
end;

function TQRPositions.NewPosition(Position : extended) : integer;
var
  I : integer;
begin
  Result := 0;
  for I := 0 to List.Count - 1 do
  begin
    if round(TQRPositionEntry(List[I]).ExactPosition) = round(Position) then
    begin
      Result := TQRPositionEntry(List[I]).NewPosition;
      Exit;
    end;
  end;
end;

procedure TQRPositions.Add(Position : extended);
var
  I : integer;
begin
  if Updating then
  begin
    for I := 0 to List.Count - 1 do
      if round(TQRPositionEntry(List[I]).ExactPosition) = round(Position) then
      begin
        inc(TQRPositionEntry(List[I]).Clients);
        Exit;
      end;
    List.Add(TQRPositionEntry.Create(Position));
  end;
end;

function TQRAbstractExportFilter.GetFilterName : string;
begin
  result := 'QRAbstract'; // Do not translate
end;

function TQRAbstractExportFilter.GetDescription : string;
begin
  Result := '';
end;

function TQRAbstractExportFilter.GetExtension : string;
begin
  Result := '';
end;

procedure TQRAbstractExportFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
begin
  CreateStream(Filename);
  Entries := TList.Create;
  FFont := TFont.Create;
  FActiveFont := TFont.Create;
  FFont.Assign(Font);
  CharHeight := Font.Size * (254 / 72);
  CharWidth := Font.Size * (254 / 72);
  FPaperHeight := PaperHeight;
  FPaperWidth := PaperWidth;
  LineCount := round(PaperHeight / CharHeight);
  FPageProcessed := false;
  inherited Start(PaperWidth, PaperHeight, Font);
end;


procedure TQRAbstractExportFilter.CreateStream(Filename : string);
begin
  FStream := TFileStream.Create(Filename, fmCreate);
end;

procedure TQRAbstractExportFilter.CloseStream;
begin
  FStream.Free;
end;

procedure TQRAbstractExportFilter.WriteToStream(const AText : string);
begin
  Stream.Write(AText[1], length(AText));
end;

procedure TQRAbstractExportFilter.WriteLnToStream(const AText : string);
begin
  WriteToStream(AText + #13 + #10);
end;


procedure TQRAbstractExportFilter.Finish;
begin
  ClearEntries;
  Entries.Free;
  FFont.Free;
  FActiveFont.Free;
  CloseStream;
  inherited Finish;
end;

procedure TQRAbstractExportFilter.ClearEntries;
var
  aEntry : TTextEntry;
begin
  while Entries.Count > 0 do
  begin
    aEntry := Entries[0];
    Entries.Delete(0);
    AEntry.TextFont.Free;
    aEntry.Free;
  end;
end;

procedure TQRAbstractExportFilter.NewPage;
begin
  if Entries.Count > 0 then
    ClearEntries;
  FPageProcessed := False;
  FActiveFont.Free;
  FActiveFont := TFont.Create;
  inherited NewPage;
end;

procedure TQRAbstractExportFilter.EndPage;
begin
  ProcessPage;
  ClearEntries;
  inherited EndPage;
end;

procedure TQRAbstractExportFilter.ConvertToColumns;
var
  I : integer;
begin
  with TQRPositions.Create do
  try
    BeginUpdate;
    for I := 0 to Entries.Count - 1 do
      if TObject(Entries[I]) is TTextEntry then
        with TTextEntry(Entries[I]) do
          Add(XPos);
    EndUpdate;
    FColCount := 0;
    for I := 0 to Entries.Count - 1 do
      if TObject(Entries[I]) is TTextEntry then
        with TTextEntry(Entries[I]) do
        begin
          XPos := NewPosition(XPos);
          if XPos > FColCount then
            FColCount := round(XPos);
        end;
  finally
    Free;
  end;
end;

procedure TQRAbstractExportFilter.ConvertToLines;
var
  I : integer;
begin
  with TQRPositions.Create do
  try
    IgnoreClientCount := True;
    BeginUpdate;
    for I := 0 to Entries.Count - 1 do
      if TObject(Entries[I]) is TTextEntry then
        with TTextEntry(Entries[I]) do
          Add(YPos);
    EndUpdate;
    FLineCount := 0;
    for I := 0 to Entries.Count - 1 do
      if TObject(Entries[I]) is TTextEntry then
        with TTextEntry(Entries[I]) do
        begin
          YPos := NewPosition(YPos);
          if YPos > FLineCount then
            FLineCount := round(YPos);
        end;
  finally
    Free;
  end;
end;

procedure TQRAbstractExportFilter.ProcessPage;
begin
  FPageProcessed := True;
  ConvertToColumns;