grimgctrl.pas

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

    end;
  end; // fire onprint event
  aWidth := Size.Width;
  if ParentReport.FinalPass and not Transparent then
    with aCanvas do
    begin
      Pen.Width := 0;
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(rect(QRPrinter.XPos(aLeft),
                    QRPrinter.YPos(aTop),
                    QRPrinter.XPos(aLeft + aWidth),
                    QRPrinter.YPos(aTop + aHeight)));
    end;
  if ParentReport.FinalPass then
    if not AutoSize then;

  if Frame.AnyFrame then
  begin
    if Frame.DrawTop then
      aTop := aTop + round(Frame.Width / 72 * 254 );
    if Frame.DrawLeft then
      aLeft := aLeft + round(Frame.Width / 72 * 254 )
  end;

  { Get our rectangle for the next line }
  aRect := Rect(0, 0, QRPrinter.XSize(aWidth), QRPrinter.YSize(LineHeight));

  AAlignment := Alignment;

  { Calculate some stuff... }
  ControlBottom := aTop + aHeight + 1;
  Y := aTop;
  if not AutoSize then
    X := aLeft
  else
  begin
    case Alignment of
      TaLeftJustify : X := aLeft;
      TaRightJustify: X := aLeft - (aWidth - OrgWidth);
      TaCenter : X := aLeft - ((aWidth - OrgWidth) / 2);
    end;
  end;

  SetBkMode(aCanvas.Handle, Windows.Transparent);
  { Set the attributes and update X for alignment }
  HasExpanded := false;

  if CanPrint then
  begin
    PrintLine(0);
    PrintFinished := true;
  end;

  SelectClipRgn(QRPrinter.Canvas.Handle, 0);

  if HasSaved then
    Caption := SavedCaption;

  if ParentReport.FinalPass and Frame.AnyFrame then
  begin
    // declare framew : integer; locally
    FrameW := round(Frame.Width / 72 * 254 );
    // QBS position frame properly
    if Frame.DrawTop then aTop := aTop - FrameW;
    if Frame.DrawRight then aWidth := aWidth + (3*FrameW);
    if Frame.DrawLeft then aleft := aleft - FrameW;
    TQRFixFrame(Frame).PaintIt(aCanvas,
            rect(QRPrinter.XPos(ALeft),
            QRPrinter.YPos(ATop),
            QRPrinter.XPos(ALeft + aWidth),
            QRPrinter.YPos(Atop + Size.height+ AFExpanded)),
            QRPrinter.XFactor,
            QRPrinter.YFactor);
  end;
end;

{ TQRCustomHTMLLabel }

constructor TQRCustomHTMLLabel.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;
  FShowonDocs := true;
end;

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

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

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

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

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

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

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

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

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

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

procedure TQRCustomHTMLLabel.Unprepare;
begin
  inherited Unprepare;
end;

procedure TQRCustomHTMLLabel.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 //---------------------------body of formatlines---------------------
  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 TQRCustomHTMLLabel.SetLines(Value : TStrings);
begin
  FLines.Assign(Value);
  DoneFormat := false; {xxx}
  Invalidate;
end;

procedure TQRCustomHTMLLabel.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;

procedure TQRCustomHTMLLabel.PrintToCanvas(aCanvas : TCanvas;
                                       aLeft, aTop, aWidth, aHeight,
                                       LineHeight : extended;
                                       CanExpand : boolean);
begin
end;

procedure TQRCustomHTMLLabel.Paint;
begin
  Canvas.Font.Assign(Font);
  if Canvas.Font.Size <> round(Font.Size * Zoom / 100) then
    Canvas.Font.Size := round(Font.Size * Zoom / 100);
  inherited Paint;
  PaintToCanvas(Canvas, rect(0, 0, Width, Height), false, round(Canvas.TextHeight('W')));
  PaintCorners;
end;

procedure TQRCustomHTMLLabel.Print(OfsX, OfsY : integer);
var
  aCanvas : TCanvas;
begin
  if IsEnabled then
  begin
    aCanvas := QRPrinter.Canvas;
    aCanvas.Font := Font;
    with QRPrinter do
      PrintToCanvas(QRPrinter.Canvas,
                    OfsX + Size.Left, OfsY + Size.Top,
                    Size.Width, Size.Height,
                    aCanvas.TextHeight('W') / QRPrinter.YFactor, AutoStretch);
//    inherited Print(OfsX, OfsY);
  end;
end;

procedure TQRCustomHTMLLabel.SetAutoStretch(Value : boolean);
begin
  FAutoStretch := Value;
  Invalidate;
end;

procedure TQRCustomHTMLLabel.SetCaption(Value : string);
begin
  FCaption := Value;
  FPrintCaption := Value;
  DoneFormat := false;
  FormatLines;
  Invalidate;
end;

procedure TQRCustomHTMLLabel.SetName(const Value: TComponentName);
begin
  if ((Caption = '') or (Caption = Name)) then
    Caption := Value;
  inherited SetName(Value);
end;

procedure TQRCustomHTMLLabel.SetParent(AParent : TWinControl);
begin
  inherited SetParent(AParent);
  FormatLines;
end;

procedure TQRCustomHTMLLabel.SetAlignment(Value : TAlignment);
begin
  inherited SetAlignment(Value);
end;

procedure TQRCustomHTMLLabel.SetWordWrap(Value : boolean);
begin
  FWordWrap := Value;
  Invalidate;
end;
end.