qrctrls.pas

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

  TQRExprMemo = class(TQRCustomLabel)
  private
    Merger : TQRMerger;
    FRemoveBlankLines : boolean;
  protected
    function GetCaptionBased : boolean; override;
    procedure Prepare; override;
    procedure Unprepare; override;
    procedure Print(OfsX, OfsY : integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner : TComponent); override;
  published
    property RemoveBlankLines : boolean read FRemoveBlankLines write FRemoveBlankLines;
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property Color;
    property Font;
    property Lines;
    property ParentFont;
    property Transparent;
    property WordWrap;
  end;

{ TQRDBCalc - included for backwards compatibility }

  TQRCalcOperation = (qrcSum, qrcCount, qrcMax, qrcMin, qrcAverage);

  TQRDBCalc = class(TQRExpr)
  private
    FDataField : string;
    FDataSource : TDataSource;
    FOperation : TQRCalcOperation;
    FResetBand : TQRBand;
  protected
    function GetPrintMask : string;
    procedure SetDataField(Value : string);
    procedure SetOperation(Value : TQRCalcOperation);
    procedure SetPrintMask(Value : string);
  published
    property DataField : string read FDataField write SetDataField;
    property DataSource : TDataSource read FDataSource write FDataSource;
    property OnPrint;
    property Operation : TQRCalcOperation  read FOperation write SetOperation;
    property ParentFont;
    property PrintMask : string read GetPrintMask write SetPrintMask;
    property ResetBand : TQRBand read FResetBand write FResetBand;
  end;

implementation

uses
  QRLablEd, QRExprEd ;

const
  BreakChars : set of Char = [' ', #13, '-'];

{ BiDiMode support routines }

function OkToChangeFieldAlignment(AField: TField; Alignment: TAlignment): Boolean;
begin
  { dont change the alignment for these fields:
    ftSmallInt     ftInteger      ftWord         ftFloat        ftCurrency
    ftBCD          ftDate         ftTime         ftDateTime     ftAutoInc }
  if Assigned(AField) then with AField do
    Result := (DataType < ftSmallInt) or
              (DataType = ftBoolean) or
              ((DataType > ftDateTime) and (DataType <> ftAutoInc))
  else
    Result := Alignment <> taCenter;
end;

function QRDBUseRightToLeftAlignment(AControl: TControl; AField: TField): Boolean;
var
  AAlignment: TAlignment;
begin
  if Assigned(AField) then
    AAlignment := AField.Alignment
  else
    AAlignment := taLeftJustify;
  { Calling AControl.UseRightToLeftAlignment cause an endless recursion }
  Result := (AControl.BiDiMode = bdRightToLeft) and
    (OkToChangeFieldAlignment(AField, AAlignment));
end;

{ TQRCustomLabel }
constructor TQRCustomLabel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FAutoSize := true;
  FAutoStretch := false;
  FWordWrap := true;
  FLines := TStringList.Create;
  FFormattedLines := TStringList.Create;
  DoneFormat := false;
  Caption := '';
  Transparent := false;
  UpdatingBounds := false;
  FFontSize := 0;
  FCaptionBased := true;
end;

destructor TQRCustomLabel.Destroy;
begin
  FLines.Free;
  FFormattedLines.Free;
  inherited Destroy;
end;

function TQRCustomLabel.GetControlsAlignment: TAlignment;
begin
  Result := Alignment;
end;

function TQRCustomLabel.GetCaption : string;
begin
  result := FCaption;
end;

function TQRCustomLabel.GetCaptionBased : boolean;
begin
  Result := FCaptionBased;
end;

procedure TQRCustomLabel.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('FontSize', ReadFontSize, WriteFontSize, true); // Do not translate
  inherited DefineProperties(Filer);
end;

procedure TQRCustomLabel.ReadFontSize(Reader : TReader);
begin
  FFontSize := Reader.ReadInteger;
end;

procedure TQRCustomLabel.WriteFontSize(Writer : TWriter);
begin
  Writer.WriteInteger(Font.Size);
end;

procedure TQRCustomLabel.Loaded;
begin
  inherited Loaded;
  if FFontSize > 0 then
    Font.Size := FFontSize;
end;

procedure TQRCustomLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
  DoneFormat := false;
 formatlines;
end;

procedure TQRCustomLabel.Prepare;
begin
  inherited Prepare;
  Caption := copy(Caption, 1, length(Caption));
end;

procedure TQRCustomLabel.Unprepare;
begin
  inherited Unprepare;
end;

procedure TQRCustomLabel.FormatLines;
var
  I, J : integer;
  NewLine : string;
  LineFinished : boolean;
  HasParent : boolean;
  MaxLineWidth : integer;
  AAlignment: TAlignment;

  function aLineWidth(Line : string) : integer;
  begin
    if HasParent then
      result := Muldiv(Longint(ParentReport.TextWidth(Font, Line)),Zoom,100)
    else
      Result := Canvas.TextWidth(Line);
  end;

  procedure FlushLine;
  begin
    FFormattedLines.Add(NewLine);
    NewLine := '';
  end;

  procedure AddWord(aWord : string);
  begin
    if aLineWidth(NewLine + aWord) > Width then
    begin
      if NewLine = '' then
      begin
        while aLineWidth(NewLine + copy(aWord, 1, 1)) < Width do
        begin
          NewLine := NewLine + copy(aWord, 1, 1);
          Delete(aWord, 1, 1);
        end;
        aWord := '';
      end;
      FlushLine;
      if aLineWidth(aWord) > Width then
      begin
        if NewLine = '' then
        begin
          if Width = 0 then
            aWord := ''
          else
            while aLineWidth(aWord) > Width do
                Delete(aWord, Length(aWord), 1);
        end;
        NewLine := aWord;
        FlushLine;
        aWord := '';
      end;
      if not WordWrap then
      begin
        aWord := '';
        LineFinished := true;
      end;
    end;
    NewLine := NewLine + aWord;
  end;

  procedure AddLine(Line : string);
  var
    aPos : integer;
  begin
    while pos(#10, Line) > 0 do
      Delete(Line, Pos(#10, Line), 1);
    aPos := pos(#13, Line);
    if aPos > 0 then
    begin
      repeat
        AddLine(copy(Line, 1, aPos - 1));
        Delete(Line, 1 , aPos);
        aPos := pos(#13, Line);
      until aPos = 0;
      AddLine(Line);
    end else
    begin
      J := 0;
      NewLine := '';
      LineFinished := false;
      if AutoSize then
      begin
        NewLine := Line;
        FlushLine;
        LineFinished := True;
      end else
      begin
        while (J < Length(Line)) and (Length(Line) > 0) do
        begin
          repeat
            inc(J)
          until (Line[J] in BreakChars) or (J >= Length(Line));
          AddWord(copy(Line, 1, J));
          Delete(Line, 1, J);
          J := 0;
        end;
        if not LineFinished then
          FlushLine;
      end;
    end;
  end;

  procedure FormatFromCaption;
  begin
    AddLine(FPrintCaption);
    if not UpdatingBounds and HasParent then
    begin
      UpdatingBounds := true;
      if Height < (longint(ParentReport.TextHeight(Font, 'W') * Zoom div 100) + 1) then
         Height := (longint(ParentReport.TextHeight(Font, 'W')) * Zoom div 100) + 1;
      UpdatingBounds := false;
    end
  end;

  procedure FormatFromStringList;
  var
    J : integer;
  begin
    if (FLines.Count <> 0) then
    begin
      if AutoSize then
        FFormattedLines.Assign(FLines)
      else
        for J := 0 to FLines.Count - 1 do
          AddLine(FLines[J]);
    end else
      if csDesigning in ComponentState then
      begin
        FCaption := Name;
        FormatFromCaption;
        FCaption := '';
      end;
  end;

begin
  if Parent <> nil then
  begin
    if assigned(FFormattedLines) then
      FFormattedLines.Clear
    else
      FFormattedLines := TStringList.Create;
    HasParent := ParentReport <> nil;
    LineFinished := false;
    if CaptionBased then
      FormatFromCaption
    else
      FormatFromStringList;
    if AutoSize and (not UpdatingBounds) and HasParent then
    begin
      MaxLineWidth := 0;
      for I := 0 to FFormattedLines.Count - 1 do
        if aLineWidth(FFormattedLines[I]) > MaxLineWidth then
          MaxLineWidth := aLineWidth(FFormattedLines[I]);
      if Frame.DrawLeft then
        MaxLineWidth := MaxLineWidth + Frame.Width;
      if Frame.DrawRight then
        MaxLineWidth := MaxLineWidth + Frame.Width;
      UpdatingBounds := true;
      AAlignment := Alignment;
      if UseRightToLeftAlignment then
        ChangeBiDiModeAlignment(AAlignment);
      case AAlignment of
        taCenter : Left := Left + ((Width - MaxLineWidth) div 2);
        taRightJustify : Left := Left + Width - MaxLineWidth;
      end;
      Width := MaxLineWidth;
      if (FFormattedLines.Count = 0) and (csDesigning in ComponentState) then
        Height := (longint(ParentReport.TextHeight(Font, 'W')) * Zoom div 100) + 1;
      if (Height < (longint(ParentReport.TextHeight(Font, 'W') * Zoom div 100) + 1)) then
        Height := (longint(ParentReport.TextHeight(Font, 'W')) * Zoom div 100) + 1;
      UpdatingBounds := false;
    end;
  end;
  DoneFormat := true;
end;

procedure TQRCustomLabel.SetLines(Value : TStrings);
begin
  FLines.Assign(Value);
  DoneFormat := false; {xxx}
  Invalidate;
end;

procedure TQRCustomLabel.PaintToCanvas(aCanvas : TCanvas; aRect : TRect; CanExpand : boolean; LineHeight: integer);
var
  I : integer;
  StartX : integer;
  StartY : integer;
  Cap : string;
  VPos : integer;
  Flags : integer;
  AAlignment: TAlignment;
begin
  FormatLines;
  Flags := 0;
{  if AutoSize then Flags := 0 else Flags := ETO_CLIPPED;}
  if not Transparent then
  begin
    aCanvas.Brush.Color := Color;
    aCanvas.Brush.Style := bsSolid;
    aCanvas.Fillrect(aRect);
  end;
  StartY := aRect.Top;
  StartX := aRect.Left;
  if Frame.AnyFrame then
  begin
    if Frame.DrawTop and (Frame.Width > 0 ) then
      StartY := StartY + round(Frame.Width / 72 * Screen.PixelsPerInch * Zoom / 100);
    if Frame.DrawLeft then
      StartX := StartX + round(Frame.Width / 72 * Screen.PixelsPerInch * Zoom / 100)
  end;
  aRect.Right := aRect.Right - aRect.Left;
  aRect.Left := 0;
  aRect.Bottom := aRect.Bottom - aRect.Top;
  aRect.Top := 0;
  SetBkMode(aCanvas.Handle, Windows.Transparent);
  begin
    AAlignment := Alignment;
    if UseRightToLeftAlignment then
      ChangeBiDiModeAlignment(AAlignment);
    case AAlignment of
      TaLeftJustify : SetTextAlign(aCanvas.Handle, TA_Left + TA_Top + TA_NoUpdateCP);
      TaRightJustify: begin
          SetTextAlign(aCanvas.Handle, TA_Right + TA_Top + TA_NoUpdateCP);
          StartX := StartX + aRect.Right;
        end;
      TaCenter : begin
          SetTextAlign(aCanvas.Handle, TA_Center + TA_Top + TA_NoUpdateCP);
          StartX := StartX + (aRect.Right - aRect.Left) div 2;
        end;
    end;
  end;
  for I := 0 to FFormattedLines.Count - 1 do
  begin
    VPos := StartY + I * LineHeight;
    begin
      Cap := FFormattedLines[I];
      if Length(Cap) > 0 then
        ExtTextOut(aCanvas.Handle, StartX, VPos, Flags, @aRect, @Cap[1], length(Cap), nil);
    end;
  end;
end;

type
  TQRFixFrame = class(TQRFrame)
  end;

{procedure TQRFixFrame.PaintFit(ACanvas : TCanvas; ARect : TRect; XFact, YFact : extended);
var
  FWX, FWY : integer;
begin
  FWX := round(XFact / 72 * 254 * Width);
  if ((FWX < 1) and (Width >= 1)) or (Width = -1) then
    FWX := 1;
  FWY := round(YFact / 72 * 254 * Width);
  if ((FWY < 1) and (Width >= 1)) or (Width = -1) then
    FWY := 1;
  ACanvas.Brush.Style := bsSolid;
  ACanvas.Brush.Color := Color;
  SetPen(ACanvas.Pen);
  with aCanvas do
  begin
    if DrawTop then
      FillRect(Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Top + FWY));
    if DrawBottom then
      FillRect(Rect(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom - FWY));
    if DrawLeft then
      FillRect(Rect(ARect.Left, ARect.Top, ARect.Left + FWX, ARect.Bottom));
    if DrawRight then
      FillRect(Rect(ARect.Right - FWX, ARect.Top, ARect.Right, ARect.Bottom));
  end;
  ACanvas.Brush.Style := bsClear;
end;}

procedure TQRCustomLabel.PrintToCanvas(aCanvas : TCanvas;
                                       aLeft, aTop, aWidth, aHeight,
                                       LineHeight : extended;
                                       CanExpand : boolean);
var