preport.pas

作者:Takeshi Kanno. PowerPdf是一款制作PDF文档的VCL控件。使用上和QuickReport类似。

var
  ln: integer;
  i: integer;
begin
  result := '';
  ln := Length(S);
  if Index > ln then
    Exit;
  i := Index;
  while true do
    if (S[i] = #10) and (S[i-1] = #13) or (S[i] = ' ') then
    begin
      result := Copy(S, Index, i - (Index -1));
      break;
    end
    else
    if i >= ln then
    begin
      result := Copy(S, Index, i - (Index - 1));
      break;
    end
    {$IFDEF USE_JPFONTS}
    else
    if ByteType(S, i) = mbTrailByte then
      if ((Copy(S, i+1, 2) <> #129#66) and
        (Copy(S, i+1, 2) <> #129#65)) then
      begin
        result := Copy(S, Index, i - (Index - 1));
        break;
      end
      else
        inc(i)
    else
    if ((i < ln) and (ByteType(S, i + 1) = mbLeadByte)) then
    begin
      result := Copy(S, Index, i - (Index - 1));
      break;
    end
    {$ENDIF}
    else
      inc(i);

   Index := i + 1;
end;

// InternalTextout
function TPRText.InternalTextout(APdfCanvas: TPdfCanvas;
                       S: string; X, Y: integer): Single;
var
  Pos: Double;
  i: integer;
  Word: string;
  ln: integer;
begin
  i := 1;
  Pos := X;
  ln := Length(S);

  if ((ln >= 2) and (S[ln] = #10) and (S[ln-1] = #13)) then
    ln := ln - 2;

  while true do
  begin
    if i > ln then
      Break;
    if ByteType(S, i) = mbLeadByte then
    begin
      Word := Copy(S, i, 2);
      inc(i);
    end
    else
      Word := S[i];
    Canvas.TextOut(Round(Pos), Y, Word);
    Pos := Pos + APdfCanvas.TextWidth(Word) + FCharSpace;
    if S[i] = ' ' then
      Pos := Pos + FWordSpace;
    inc(i);
  end;
  result := Pos;
end;

// GetFontClassName
function TPRText.GetFontClassName: string;
begin
  if FFontBold then
    if FFontItalic then
      result := PDFFONT_CLASS_BOLDITALIC_NAMES[ord(FFontName)]
    else
      result := PDFFONT_CLASS_BOLD_NAMES[ord(FFontName)]
  else
    if FFontItalic then
      result := PDFFONT_CLASS_ITALIC_NAMES[ord(FFontName)]
    else
      result := PDFFONT_CLASS_NAMES[ord(FFontName)];
end;

// Paint
procedure TPRText.Paint;
var
  i: integer;
  S1, S2: string;
  XPos: Single;
  TmpXPos: Double;
  ARect: TRect;
  ln: integer;
  PdfCanvas: TPdfCanvas;
  FText: string;
  ForceReturn: boolean;
  tmpWidth: Single;

  procedure DrawRect;
  begin
    with Canvas do
    begin
      Pen.Color := clNavy;
      Pen.Style := psDot;
      MoveTo(0, 0);
      LineTo(Width-1, 0);
      LineTo(Width-1, Height-1);
      LineTo(0, Height-1);
      LineTo(0, 0);
    end;
  end;

begin
  PdfCanvas := GetInternalDoc.Canvas;
  with PdfCanvas do
  begin
    SetFont(GetFontClassName, FontSize);
    SetLeading(Leading);
    SetWordSpace(WordSpace);
    SetCharSpace(CharSpace);
  end;

  with Canvas do
  begin
    Font := Self.Font;
    ARect := ClientRect;
    FText := Lines.Text;
    i := 1;
    XPos := ARect.Left;

    while i <= Length(FText) do
    begin
      ln := Length(S2);
      if (ln >= 2) and (S2[ln] = #10) and (S2[ln-1] = #13) then
      begin
        S2 := Copy(S2, 1, ln - 2);
        ForceReturn := true;
      end
      else
        ForceReturn := false;

      S1 := GetNextWord(FText, i);
      tmpWidth := PdfCanvas.TextWidth(S1);
      TmpXPos := XPos + tmpWidth;

      if (FWordWrap and (TmpXPos > ARect.Right)) or
        ForceReturn then
      begin
        if S2 <> '' then
          InternalTextOut(PdfCanvas, S2, ARect.Left, ARect.Top);
        S2 := '';
        ARect.Top := ARect.Top + Round(Leading);
        if ARect.Top > ARect.Bottom - FontSize then
          Break;
        XPos := ARect.Left;
      end;
      XPos := XPos + tmpWidth;
      if S1[Length(S1)] = ' ' then
        XPos := XPos + WordSpace;
      S2 := S2 + S1;
    end;

    if S2 <> '' then
      InternalTextout(PdfCanvas, S2, ARect.Left, ARect.Top);
  end;

  DrawRect;
end;

// Print
procedure TPRText.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  i: integer;
  S1, S2: string;
  XPos, YPos: Single;
  tmpXPos: Single;
  tmpWidth: Single;
  ln: integer;
  FourceReturn: boolean;
  FText: string;

  procedure InternalShowText(S: string; AWidth: integer);
  var
    i: Integer;
  begin
    with ACanvas.PdfCanvas do
    begin
      i := MesureText(S, AWidth);
      S := Copy(S, 1, i);
      ShowText(S);
    end;
  end;

begin
  if not Printable then Exit;

  with ACanvas.PdfCanvas do
  begin
    SetFont(GetFontClassName, FontSize);
    SetRGBFillColor(FontColor);
    SetCharSpace(CharSpace);
    SetWordSpace(WordSpace);
    SetLeading(Leading);

    BeginText;

    i := 1;
    XPos := ARect.Left;
    FText := Text;
    // translate screen coordinates to PDF coordinates.
    YPos := GetPage.Height - ARect.Top - FontSize*0.85;
    MoveTextPoint(Round(XPos), Round(YPos));

    while i <= Length(FText) do
    begin
      ln := Length(S2);
      if (ln >= 2) and (S2[ln] = #10) and (S2[ln-1] = #13) then
      begin
        S2 := Copy(S2, 1, ln - 2);
        FourceReturn := true;
      end
      else
        FourceReturn := false;

      S1 := GetNextWord(FText, i);
      tmpWidth := ACanvas.PdfCanvas.TextWidth(S1);
      TmpXPos := XPos + tmpWidth;

      if (FWordWrap and (TmpXPos > ARect.Right)) or
        FourceReturn then
      begin
        if S2 <> '' then
          InternalShowText(S2, ARect.Right - ARect.Left);
        S2 := '';
        MoveToNextLine;
        ARect.Top := ARect.Top + Round(Leading);
        if ARect.Top > ARect.Bottom - FontSize then
          Break;
        XPos := ARect.Left;
      end;
      XPos := XPos + tmpWidth;
      if S1[Length(S1)] = ' ' then
        XPos := XPos + WordSpace;
      S2 := S2 + S1;
    end;

    if S2 <> '' then
      InternalShowText(S2, ARect.Right - ARect.Left);
    EndText;
  end;
end;

// SetCharSpace
procedure TPRText.SetCharSpace(Value: Single);
begin
  if (Value <> FCharSpace) then
  begin
    FCharSpace := Value;
    Invalidate;
  end;
end;

// SetLeading
procedure TPRText.SetLeading(Value: Single);
begin
  if (Value <> FLeading) and (Value >= 0) then
  begin
    FLeading := Value;
    Invalidate;
  end;
end;

// SetWordSpace
procedure TPRText.SetWordSpace(Value: Single);
begin
  if (Value <> FWordSpace) and (Value >= 0) then
  begin
    FWordSpace := Value;
    Invalidate;
  end;
end;

// SetWordwrap
procedure TPRText.SetWordwrap(Value: boolean);
begin
  if Value <> FWordwrap then
  begin
    FWordwrap := Value;
    Invalidate;
  end;
end;

// SetFontColor
procedure TPRText.SetFontColor(Value: TColor);
begin
  if Value > $0FFFFFFF then
    raise EPdfInvalidValue.Create('the color you selected is not allowed.');
  if (Value <> FFontColor) then
  begin
    FFontColor := Value;
    Font.Color := Value;
    Invalidate;
  end;
end;

{ TPRRect }

// Create
constructor TPRRect.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLineColor := clBlack;
  FFillColor := clNone;
end;

// SetLineColor
procedure TPRRect.SetLineColor(Value: TColor);
begin
  if Value <> FLineColor then
  begin
    FLineColor := Value;
    Invalidate;
  end;
end;

// SetLineStyle
procedure TPRRect.SetLineStyle(Value: TPenStyle);
begin
  if Value <> FLineStyle then
  begin
    FLineStyle := Value;
    Invalidate;
  end;
end;

// SetFillColor
procedure TPRRect.SetFillColor(Value: TColor);
begin
  if Value <> FFillColor then
  begin
    FFillColor := Value;
    Invalidate;
  end;
end;

// SetLineWidth
procedure TPRRect.SetLineWidth(Value: Single);
begin
  if (Value <> FLineWidth) and (Value >= 0) then
  begin
    FLineWidth := Value;
    Invalidate;
  end;
end;

// Paint
procedure TPRRect.Paint;
var
  ARect: TRect;
begin
  ARect := ClientRect;
  with ARect, Canvas do
  begin
    if Height > 1 then
      Bottom := Bottom - 1;
    if Width > 1 then
      Right := Right - 1;

    if FillColor <> clNone then
    begin
      Brush.Color := FFillColor;
      Brush.Style := bsSolid;
      FillRect(ARect);
    end
    else
      Brush.Style := bsClear;

    if LineColor <> clNone then
    begin
      Pen.Style := FLineStyle;
      Pen.Width := Round(FLineWidth);
      Pen.Color := FLineColor;
      Polygon([Point(Left,Top), Point(Right,Top),
        Point(Right,Bottom), Point(Left,Bottom)]);
    end;
  end;
end;

// Print
procedure TPRRect.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  PageHeight: integer;

  procedure SetDash(APattern: TPenStyle);
  begin
    // emurate TPenStyle
    with ACanvas.PdfCanvas do
      case APattern of
        psSolid, psInsideFrame: SetDash([0], 0);
        psDash: SetDash([16, 8], 0);
        psDashDot: SetDash([8, 7, 2, 7], 0);
        psDashDotDot: SetDash([8, 4, 2, 4, 2, 4], 0);
        psDot: SetDash([3], 0);
      end;
  end;
begin
  if not Printable then Exit;

  PageHeight := GetPage.Height;
  with ARect do
  begin
    Top := PageHeight - Top;
    if Height > 1 then
      Bottom := PageHeight - Bottom + 1
    else
      Bottom := PageHeight - Bottom;
    if Width > 1 then
      Right := Right - 1;

    if (Height <= 1) and (Width <= 1) then Exit;

    if (LineColor = clNone) or (LineStyle = psClear) then
      if (Height <= 1) or (Width <= 1) then Exit;

    SetDash(FLineStyle);

    with ACanvas.PdfCanvas do
    begin
      MoveTo(Left, Top);

      if Width > 1 then
      begin
        LineTo(Right, Top);
        if Height > 1 then
          LineTo(Right, Bottom);
      end;
      if Height > 1 then
        LineTo(Left, Bottom);

      if (FillColor <> clNone) and (Width > 1) and (Height > 1) then
        SetRGBFillColor(FFillColor);

      if LineColor <> clNone then
      begin
        SetRGBStrokeColor(FLineColor);
        SetLineWidth(FLineWidth);
      end;

      if FillColor <> clNone then
        if (Width > 1) and (Height > 1) then
          if (LineColor <> clNone) and (LineStyle <> psClear) then
            ClosepathFillStroke
          else
          begin
            Closepath;
            Fill;
          end
        else
        begin
          Stroke;
          Newpath;
        end
      else
        if (Width > 1) and (Height > 1) then
          ClosePathStroke
        else
        begin
          Stroke;
          Newpath;
        end;
    end;
  end;
end;

{ TPRImage }

// Paint
procedure TPRImage.Paint;
begin
  if (FPicture = nil) or (FPicture.Graphic = nil) or
   (FPicture.Graphic.Empty) or not (FPicture.Graphic is TBitmap) then
    with Canvas do
    begin
      TextOut(4, 4, Name);
      Pen.Color := clBlue;
      Pen.Style := psDot;

      Polygon([Point(0, 0), Point(Width-1, 0),
        Point(Width-1, Height-1), Point(0, Height-1)]);
    end
  else
    Canvas.StretchDraw(GetClientRect, FPicture.Graphic)
end;

// Print
procedure TPRImage.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  FDoc: TPdfDoc;
  FXObjectName: string;
  i: integer;
begin
  if not Printable then Exit;

  if (FPicture = nil) or (FPicture.Graphic = nil) or
   (FPicture.Graphic.Empty) or not (FPicture.Graphic is TBitmap) then
    Exit;
  FDoc := ACanvas.PdfCanvas.GetDoc;
  if SharedImage then
  begin
    FXObjectName := Self.Name;
    if FDoc.GetXObject(FXObjectName) = nil then
      FDoc.AddImage(FXObjectName, FPicture.Graphic, 'Pdf-Bitmap');
  end
  else
  begin
    for i := 1 to MAX_IMAGE_NUMBER do
    begin
      FXObjectName := Self.Name + IntToStr(Random(MAX_IMAGE_NUMBER));
      if FDoc.GetXObject(FXObjectName) = nil then Break;
      if i = MAX_IMAGE_NUMBER then
        raise Exception.Create('image count over max value..');
    end;
    FDoc.AddImage(FXObjectName, FPicture.Graphic, 'Pdf-Bitmap');
  end;
  with ARect do
    ACanvas.PdfCanvas.DrawXObject(Left, GetPage.Height - Bottom,
      Right - Left, Bottom - Top, FXObjectName);
end;

// Create
constructor TPRImage.Create(AOwner: TComponent);
begin
  inherited;
  FPicture := TPicture.Create;
  FSharedImage := true;
  Randomize;
end;

// SetPicture
procedure TPRImage.SetPicture(Value: TPicture);
begin
  if Value.Graphic is TBitmap then
  begin
    FPicture.Assign(Value);
    Invalidate;
  end
  else
    raise exception.Create('only bitmap image is allowed.');
end;

// Destroy
destructor TPRImage.Destroy;
begin
  FPicture.Free;
  inherited;
end;

{ Registoer }

procedure Register;
begin
  RegisterComponents('PdfReport', [TPReport,
                                   TPRPage,
                                   TPRLayoutPanel,
                                   TPRGridPanel,
                                   TPRText,
                                   TPRRect,
                                   TPRImage
                                   ]);
  RegisterNoIcon([TPdfDoc]);
end;

end.