qreport.pas

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

{ :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  :: QuickReport 4.0 for Delphi and C++Builder               ::
  ::                                                         ::
  :: QREPORT.PAS - COMPONENT REGISTRATION & PROPERTY EDITORS ::
  ::                                                         ::
  :: Copyright (c) 1998 QuSoft AS                            ::
  :: All Rights Reserved                                     ::
  ::                                                         ::
  :: web: http://www.qusoft.no                               ::
  :: Added Gr controls, removed HTML filter control          ::
  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: }

{$I QRDEFS.INC}


unit Qreport;

interface
                                                                                                                       
uses
  Classes, QuickRpt, DesignIntf, DesignEditors, ExptIntf, QRWizard, QRIDEWz;

procedure Register;

type
  { TQRFloatProperty - Floating point property editor with 3 fixed decimal places and support for
    unit settings }
  TQRFloatProperty = class(TFloatProperty)
  public
    function GetValue : string; override;
    procedure SetValue(const Value : string); override;
  end;

  { TQRMasterProperty - property editor for the Master property, showing
    TQuickRep and TQRController components only }
  TQRMasterProperty = class(TComponentProperty)
  public
    procedure GetValues(Proc: TGetStrProc); override;
  end;

  { TQRCaptionProperty - just a copy of TCaptionProperty }
  TQRCaptionProperty = class(TStringProperty);

  { TQRGraphicsEditor - Component editor for TQRImage, copied from
    PICEDIT.PAS for Delphi 3.0 compatibility }

  TQRGraphicEditor = class(TDefaultEditor)
  public
    procedure EditProperty(const Prop: IProperty; var Continue: Boolean); override;

//    procedure EditProperty(PropertyEditor : TPropertyEditor; var Continue, FreeEditor : Boolean); override;
  end;

  { TDataFieldProperty }
  TQRDBStringProperty = class(TStringProperty)
  public
    function GetAttributes : TPropertyAttributes; override;
    procedure GetValueList(List : TStrings); virtual; abstract;
    procedure GetValues(Proc : TGetStrProc); override;
  end;

  TQRDataFieldProperty = class(TQRDBStringProperty)
  public
    function GetDataSetPropName : string; virtual;
    procedure GetValueList(List : TStrings); override;
  end;

  { TQRExprPropEditor }
  TQRExprProperty = class(TStringProperty)
  public
    function GetAttributes : TPropertyAttributes; override;
    procedure Edit; override;
  end;

  { TQREnvPropEditor }
  TQREnvProperty = class(TPropertyEditor)
  public
    function GetAttributes : TPropertyAttributes; override;
    procedure Edit; override;
  end;

function GetDesignVerb(Index: Integer): string;
function GetDesignVerbCount: Integer;
procedure ExecuteDesignVerb(Index: Integer; Report: TQuickRep);

implementation

uses
  sysutils, windows, typinfo, controls, stdctrls, forms, qrprntr,
  db, QRCtrls, QRExtra, Dialogs, QRAbout, QRComped, QRExpbld, QR4Const,
  QRExport, QREditor, QREnvEd, QRExpr,GrImgctrl, qrxmlsfilt,
  QRPDFFilt, QRWebfilt, QRAbsDatas;

{$R QRNEW.RES}

function TQRDBStringProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList, paSortList, paMultiSelect];
end;

procedure TQRDBStringProperty.GetValues(Proc: TGetStrProc);
var
  I: Integer;
  Values: TStringList;
begin
  Values := TStringList.Create;
  try
    GetValueList(Values);
    for I := 0 to Values.Count - 1 do Proc(Values[I]);
  finally
    Values.Free;
  end;
end;

function TQRDataFieldProperty.GetDataSetPropName: string;
begin
  Result := 'DataSet'; {<-- do not resource}
end;

procedure TQRDataFieldProperty.GetValueList(List: TStrings);
var
  Instance: TComponent;
  PropInfo: PPropInfo;
  DataSet: TDataSet;
begin
  Instance := TComponent(GetComponent(0));
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, GetDataSetPropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  begin
    DataSet := TObject(GetOrdProp(Instance, PropInfo)) as TDataSet;
    if (DataSet <> nil) then
      DataSet.GetFieldNames(List);
  end;
end;

{ TQRFloatProperty }

function TQRFloatProperty.GetValue : String;
var
  AUnit : TQRUnit;
begin
  AUnit := TQRUnitBase(GetComponent(0)).Units;
  case AUnit of
    MM : result := FloatToStrF(GetFloatValue, ffFixed, 18, 1) + 'mm'; // Do not translate
    Inches : result := FloatToStrF(GetFloatValue, ffFixed, 18, 3) + 'in'; // Do not translate
  end;
end;

procedure TQRFloatProperty.SetValue(const Value : string);
var
  FixedValue : string;
  AUnit : TQRUnit;
  NewUnit : TQRUnit;

  procedure Remove(What : string; var From : string);
  begin
    while Pos(What, From) > 0 do
      Delete(From, Pos(What, From), Length(What));
  end;

begin
  AUnit := TQRUnitBase(GetComponent(0)).Units;
  NewUnit := AUnit;
  FixedValue := Value;

  if (Copy(FixedValue, Length(FixedValue), 1) = '"') or
    (UpperCase(Copy(FixedValue, Length(FixedValue) - 1, 2)) = 'IN')  then // Do not translate
    NewUnit := Inches
  else
    if UpperCase(Copy(FixedValue, Length(FixedValue) - 1, 2)) = 'MM' then // Do not translate
      NewUnit := MM;

  Remove('mm', FixedValue); // Do not translate
  Remove(' ', FixedValue);
  Remove('"', FixedValue);
  Remove('in', FixedValue); // Do not translate

  if AUnit <> NewUnit then
  begin
    case AUnit of
      MM : begin end;
    end;
  end;
  inherited SetValue(FixedValue);
end;

{ TQRMasterProperty }

procedure TQRMasterProperty.GetValues(Proc: TGetStrProc);
var
  I: Integer;
  Root: TComponent;
  Component: TComponent;
begin
{$ifndef ver100}
  Root := Designer.GetRoot;
{$else}
  Root := TFormDesigner(Designer).GetRoot;
{$endif}
  if Root is TQuickRep then Proc(Root.Name);
  for I := 0 to Root.ComponentCount - 1 do
  begin
    Component := Root.Components[I];
    if ((Component is TCustomQuickRep) or (Component is TQRController) or
       (Component is TQRControllerBand)) and
       (Component.Name <> '') then
      Proc(Component.Name);
  end;
end;

{ TQRGraphicsEditor }

procedure TQRGraphicEditor.EditProperty(const Prop: IProperty; var Continue: Boolean);
//procedure TQRGraphicEditor.EditProperty(PropertyEditor: TPropertyEditor; var Continue, FreeEditor: Boolean);
var
  PropName: string;
begin
  PropName := Prop.GetName;
  if (CompareText(PropName, 'PICTURE') = 0) then // Do not translate
  begin
    Prop.Edit;
    Continue := False;
  end;
end;

{ TQRExprProperty }

function TQRExprProperty.GetAttributes : TPropertyAttributes;
begin
  Result := inherited GetAttributes + [paDialog];
end;

procedure TQRExprProperty.Edit;
var
  AValue : string;
  AExpr : TQRExpr;
  AGroup : TQRGroup;
  aenv : TQREvEnvironment;
begin
  AValue:=Value;
  if GetComponent(0) is TQRExpr then
  begin
    AExpr := TQRExpr(GetComponent(0));
    if AExpr.ParentReport <> nil then
    begin
      aEnv := AExpr.ParentReport.Functions;
      if GetExpression('', AValue, TCustomForm(AExpr.Owner), nil, AEnv) then
        Value := AValue
    end
  end else
    if GetComponent(0) is TQRGroup then
    begin
      AGroup := TQRGroup(GetComponent(0));
      if AGroup.PArentReport <> nil then
        if GetExpression('', AValue, TCustomForm(Agroup.Owner), nil, AGroup.ParentReport.Functions) then
          Value := AValue
    end
end;

{ TQREnvProperty }

function TQREnvProperty.GetAttributes : TPropertyAttributes;
begin
  Result := inherited GetAttributes + [paDialog];
end;

procedure TQREnvProperty.Edit;
begin
  EditEnvironment(TCustomQuickRep(GetComponent(0)).Functions, false, nil);
end;

function GetDesignVerb(Index: Integer): string;
begin
  case Index of
    0 : result := cQRName;
    1 : result := SqrCopyright;
    2 : result := '-';
    3 : result := SqrAboutQR;
    4 : result := SqrReportSettings;
    5 : result := SqrPreview;
    6 : result := '-';
    7 : result := SqrZoomIn;
    8 : result := SqrZoomOut;
  end;
end;

function GetDesignVerbCount: Integer;
begin
  Result := 9;
end;

procedure EditReport(Report: TQuickRep);
begin
  with TQRCompEd.Create(Application) do
  try
    QuickRep:=Report;
    ShowModal;
  finally
    free;
  end;
end;