qrextra.pas

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

{ :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  :: QuickReport 4.0 for Delphi and C++Builder               ::
  ::                                                         ::
  :: QREXTRA.PAS - ADDITIONAL CLASSES                        ::
  ::                                                         ::
  :: Copyright (c) 2003 A Lochert / QBS Software             ::
  :: All Rights Reserved                                     ::
  ::                                                         ::
  :: web: http://www.qusoft.com                              ::
  ::                                                         ::
  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: }

{$I QRDEFS.INC}

unit QRExtra;

interface

{$R-}
{$T-}
{$B-}

uses Windows, SysUtils, Classes, Controls, StdCtrls, ExtCtrls, Graphics, Buttons,
     Forms, Dialogs, Printers, DB, Clipbrd, QRPrntr, QuickRpt, QRCtrls, QRCompEd,
     QRExpBld, DBTables;

type
  { TQRPrintJob }
  TQRPrintJob = class
  protected
    procedure CreateOutput(AQRPrinter : TQRPrinter); virtual;
  public
    procedure Preview;
    procedure Print;
  end;

  { TQRPHandler }
  TQRPHandler = class
  private
    FFilename : string;
  protected
    procedure SetFilename(Value : string);
  public
    FQRPrinter : TQRPrinter;
    constructor Create;
    destructor Destroy; override;
    procedure Preview;
    procedure Print;
    property Filename : string read FFilename write SetFilename;
  end;

  { TQRBuilder - base report builder class }
  TQRBuilder = class(TComponent)
  private
    FActive : boolean;
    FFont : TFont;
    FOrientation : TPrinterOrientation;
    FReport : TCustomQuickRep;
    FTitle : string;
    NameList : TStrings;
  protected
    function NewName(AClassName : string) : string;
    procedure BuildFramework; virtual;
    procedure RenameObjects;
    procedure SetActive(Value : boolean); virtual;
    procedure SetOrientation(Value : TPrinterOrientation); virtual;
    procedure SetTitle(Value : string); virtual;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    function FetchReport : TCustomQuickRep;
    property Active : boolean read FActive write SetActive;
    property Font : TFont read FFont write FFont;
    property Orientation : TPrinterOrientation read FOrientation write SetOrientation;
    property Report : TCustomQuickRep read FReport write FReport;
    property Title : string read FTitle write SetTitle;
  published
  end;

  { TQRListBuilder - Simple list report builder class }
  TQRListBuilder = class(TQRBuilder)
  private
    FDataSet : TDataSet;
    FFields : TStrings;
    procedure SetFields(Value : TStrings);
  protected
    procedure SetActive(Value : boolean); override;
    procedure BuildList; virtual;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure AddAllFields;
    property DataSet : TDataSet read FDataSet write FDataSet;
    property Fields : TStrings read FFields write SetFields;
  end;


{ Report builder procedures }

procedure QRCreateList(var AReport : TCustomQuickRep; AOwner : TComponent;
                       aDataSet : TDataSet; aTitle : string; aFieldList : TStrings);

function AllDataSets(Form : TCustomForm; IncludeDataModules : boolean) : TStrings;

procedure PopulateFontSizeCombo(aCombo : TComboBox);

function QRLoadReport(Filename : string) : TQuickRep;

procedure QRFreeReport(aReport : TQuickRep);

{ Netafile searching }

function StrInMetafile(AString : string; AMetafile : TMetafile; MatchCase : boolean) : boolean;

implementation

uses QR4Const;

type
  MFBar = array of char;
var
  MFSearchStr : string;
  MFFound : boolean;
  MFMatchCase : boolean;
  MFSearchBusy : boolean;

{var
  QRToolbarLibrary : TQRLibrary;}

const
  cqrToolBarHeight = 90;
  cqrStatusBarHeight = 20;

  cQRFontSizeCount = 16;
  cQRFontSizes : array[1..cQRFontSizeCount] of integer =
      (8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72);

{ Utility routines }

function MetaEnum(DC : THandle; HandleTable : pointer; MetaRec : Pointer; Count : word; dummy : pointer) : shortint stdcall;
var
  aStr : string;
  Ofs : integer;
  Len : integer;
  I : integer;
begin
  aStr := '';
  with tagENHMETARECORD(MetaRec^) do
  begin
    case iType of
      EMR_EXTTEXTOUTW,
      EMR_EXTTEXTOUTA : begin
                          aStr := '';
                          Ofs := (tagEMREXTTEXTOUTA(Metarec^).EMRText.offString);
                          Len := (tagEMREXTTEXTOUTA(Metarec^).EMRText.nChars);
                          SetLength(aStr, Len);
                          for I := 0 to len - 1 do
                            aStr[I+1] := MFBar(MetaRec)[ofs + (I*2)];
                        end;
    end;
  end;
  if not MFMatchCase then aStr := AnsiUppercase(AStr);
  if Pos(MFSearchStr, aStr) > 0 then
  begin
    Result := 0;
    MFFound := true;
  end else
    Result := 1;
end;

function StrInMetafile(AString : string; AMetafile : TMetafile; MatchCase : boolean) : boolean;
begin
  while MFSearchBusy do Application.ProcessMessages;
  MFSearchBusy := true;
  if MatchCase then
    MFSearchStr := AString
  else
    MFSearchStr := AnsiUppercase(AString);
  MFFound := false;
  MFMatchCase := MatchCase;
  EnumEnhMetafile(0, AMetafile.handle, @MetaEnum, nil, rect(0,0,0,0));
  Result := MFFound;
  MFSearchBusy := false;
end;

procedure PopulateFontSizeCombo(aCombo : TComboBox);
var
  I : integer;
begin
  aCombo.Items.Clear;
  for I := 1 to cQRFontSizeCount do
    aCombo.Items.Add(IntToStr(cQRFontSizes[I]));
end;

function AllDataSets(Form : TCustomForm; IncludeDataModules : boolean) : TStrings;
var
  J : integer;

  procedure AddForm(AControl : TWinControl);
  var
    I : integer;
  begin
    for I:=0 to AControl.ComponentCount - 1 do
    begin
      if AControl.Components[I] is TDataSet then
        Result.AddObject(TDataSet(AControl.Components[I]).Name, AControl.Components[I])
      else
        if AControl.Components[I] is TWinControl then
          AddForm(TWinControl(AControl.Components[I]));
    end;
  end;

  procedure AddDM(DM : TDataModule);
  var
    I : integer;
  begin
    for I:=0 to DM.ComponentCount - 1 do
      if DM.Components[I] is TDataSet then
        Result.AddObject(TDataSet(DM.Components[I]).Name, DM.Components[I]);
  end;

begin
  Result := TStringList.Create;
  if Form <> nil then
    AddForm(Form);
  if IncludeDataModules then
    for J := 0 to Screen.DataModuleCount - 1 do
      AddDM(Screen.DataModules[J]);
end;

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

function QRLoadReport(Filename : string) : TQuickRep;
{ a QRLoadReport'ed report should always be freed with QRFreeReport }
var
  aForm : TForm;
begin
  result := nil;
  try
    aForm := TForm.Create(Application);
    ReadComponentResFile(Filename, aForm);
    if (aForm.ComponentCount > 0) and (aForm.Components[0] is TQuickRep) then
      result := TQuickRep(aForm.Components[0]);
  except
    ShowMessage(SqrErrorLoading);
  end;
end;

procedure QRFreeReport(aReport : TQuickRep);
begin
  aReport.Owner.Free;
end;

{ TQRPrintJob }

procedure TQRPrintJob.CreateOutput(AQRPrinter : TQRPrinter);
begin
end;

procedure TQRPrintJob.Preview;
var
  aQRPrinter : TQRPrinter;
begin
    aQRPrinter := TQRPrinter.Create(nil);
  with aQRPrinter do
  try
    Destination := qrdMetafile;
//    OnGenerateToPrinter := Self.Print;
    Preview;
    Application.ProcessMessages;
    CreateOutput(aQRPrinter);
    repeat
      Application.ProcessMessages
    until not aQRPrinter.ShowingPreview;
  finally
    Free;
  end;
end;

procedure TQRPrintJob.Print;
var
  aQRPrinter : TQRPrinter;
begin
    aQRPrinter := TQRPrinter.Create(nil);
  with aQRPrinter do
  try
    Destination := qrdPrinter;
    CreateOutput(aQRPrinter);
  finally
    Free;
  end;
end;

{ TQRPHandler }

constructor TQRPHandler.Create;
begin
  FFilename := '';
  FQRPrinter := nil;
end;

destructor TQRPHandler.Destroy;
begin
  if assigned(FQRPrinter) then
    FQRPrinter.Free;
  inherited Destroy;
end;

procedure TQRPHandler.SetFilename(Value : string);
begin
  if FFilename <> Value then
  begin
    if assigned(FQRPrinter) then FQRPrinter.Free;
    FQRPrinter := TQRPrinter.Create(nil);
    FFilename := Value;