preport.pas

给PDF文件加盖印章或背景

  FFontSize := 12;
  FFontBold := false;
  FFontItalic := false;
  {$IFDEF USE_JPFONTS}
  FFontName := fnGothic;
  {$ENDIF}
  Font.Name := ITEM_FONT_NAMES[ord(FFontName)];
  Font.CharSet := ITEM_FONT_CHARSETS[ord(FFontName)];
  Font.Size := Round(FFontSize*0.75);
  ParentFont := false;
end;

// SetFontName
procedure TPRCustomLabel.SetFontName(Value: TPRFontName);
begin
  if FFontName <> Value then
  begin
    FFontName := Value;
    Font.Name := ITEM_FONT_NAMES[ord(Value)];
    Font.CharSet := ITEM_FONT_CHARSETS[ord(Value)];
    Invalidate;
  end;
end;

// SetFontItalic
procedure TPRCustomLabel.SetFontItalic(Value: boolean);
begin
  if FFontItalic <> Value then
  begin
    FFontItalic := Value;
    if Value then
      Font.Style := Font.Style + [fsItalic]
    else
      Font.Style := Font.Style - [fsItalic];
    Invalidate;
  end;
end;

// SetFontBold
procedure TPRCustomLabel.SetFontBold(Value: boolean);
begin
  if FFontBold <> Value then
  begin
    FFontBold := Value;
    if Value then
      Font.Style := Font.Style + [fsBold]
    else
      Font.Style := Font.Style - [fsBold];
    Invalidate;
  end;
end;

// SetFontSize
procedure TPRCustomLabel.SetFontSize(Value: Single);
begin
  if (FFontSize <> Value) and (Value > 0) then
  begin
    FFontSize := Value;
    Font.Size := Round(Value*0.75);
    Invalidate;
  end;
end;

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

// CMTextChanged
procedure TPRCustomLabel.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

// InternalTextout
function TPRCustomLabel.InternalTextout(APdfCanvas: TPdfCanvas;
                       S: string; X, Y: integer): Single;
var
  Pos: Double;
  i: integer;
  Word: string;
  ln: integer;
begin
  // printing text and the end point of canvas.
  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);
    with APdfCanvas do
      Pos := Pos + TextWidth(Word) + Attribute.CharSpace;
    if S[i] = ' ' then
      Pos := Pos + FWordSpace;
    inc(i);
  end;
  result := Pos;
end;

// GetFontClassName
function TPRCustomLabel.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;

{ TPRLabel }

// SetAlignment
procedure TPRLabel.SetAlignment(Value: TAlignment);
begin
  if Value <> FAlignment then
  begin
    FAlignment := Value;
    Invalidate;
  end;
end;

// SetAlignJustified
procedure TPRLabel.SetAlignJustified(Value: boolean);
begin
  if Value <> FAlignJustified then
  begin
    FAlignJustified := Value;
    Invalidate;
  end;
end;

// Paint
procedure TPRLabel.Paint;
var
  PdfCanvas: TPdfCanvas;
  FText: string;
  tmpWidth: Single;
  XPos: integer;
begin
  if Length(Caption) = 0 then Exit;

  PdfCanvas := GetInternalDoc.Canvas;

  // setting canvas attribute to the internal doc(to get font infomation).
  SetCanvasProperties(PdfCanvas);

  with Canvas do
  begin
    Font := Self.Font;
    FText := Caption;

    // calculate text width
    tmpWidth := PdfCanvas.TextWidth(FText);

    case FAlignment of
      taCenter: XPos := Round((Width - tmpWidth) / 2);
      taRightJustify: XPos :=Width - Round(tmpWidth);
    else
      XPos := 0;
    end;
    InternalTextout(PdfCanvas, FText, XPos, 0);
  end;
end;

// Print
procedure TPRLabel.Print(ACanvas: TPRCanvas; ARect: TRect);
begin
  if Length(Caption) = 0 then Exit;

  SetCanvasProperties(ACanvas.PdfCanvas);

  ACanvas.TextRect(ARect, Caption, FAlignment, Clipping);
end;

function TPRLabel.GetTextWidth: Single;
begin
  with GetInternalDoc do
  begin
    SetCanvasProperties(Canvas);
    Result := Canvas.TextWidth(Caption);
  end;
end;

procedure TPRLabel.SetCanvasProperties(ACanvas: TPdfCanvas);
var
  tmpWidth: Single;
  tmpCharSpace: Single;
  CharCount: integer;
begin
  // setting canvas attribute to the internal doc(to get font infomation).
  with ACanvas do
  begin
    SetFont(GetFontClassName, FontSize);
    SetRGBFillColor(FontColor);
    SetWordSpace(WordSpace);
    if AlignJustified then
    begin
      SetCharSpace(0);
      tmpWidth := TextWidth(Caption);
      CharCount := _GetCharCount(Caption);
      if CharCount > 1 then
        tmpCharSpace := (Width - tmpWidth) / (CharCount - 1)
      else
        tmpCharSpace := 0;
      if tmpCharSpace > 0 then
        SetCharSpace(tmpCharSpace);
    end
    else
      SetCharSpace(CharSpace);
  end;
end;

{ TPRText }

// SetLines
procedure TPRText.SetLines(Value: TStrings);
begin
  FLines.Assign(Value);
  Invalidate;
end;

// GetLines
function TPRText.GetLines: TStrings;
begin
  result := FLines;
end;

// SetText
procedure TPRText.SetText(Value: string);
begin
  FLines.Text := Value;
end;

// GetText
function TPRText.GetText: string;
begin
  result := Trim(FLines.Text);
end;

// Create
constructor TPRText.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLeading := 14;
  FLines := TStringList.Create;
end;

// Destroy
destructor TPRText.Destroy;
begin
  FLines.Free;
  inherited;
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
  // this is useless way, but I don't think of more smart way.
  PdfCanvas := GetInternalDoc.Canvas;

  // setting canvas attribute to the internal doc(to get font infomation).
  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;
    S2 := PdfCanvas.GetNextWord(FText, i);
    XPos := ARect.Left + PdfCanvas.TextWidth(S2);
    if (S2 <> '') and (S2[Length(S2)] = ' ') then
      XPos := XPos + WordSpace;

    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 := PdfCanvas.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);
  procedure GetFontMMSize(FontName:string; FontSize:Integer; var H,W,EW:Integer);
  var
    AText  :string;
    Ratio1 :Real;
    AFont  :TFont;
    fhGdi  :HGDIOBJ;
    DC     :HDC;
    ASize  :TSize;
  begin
    try
      AFont:=TFont.Create;
      with AFont do
      begin
        Name:=FontName;
        Size:=FontSize;
      end;
      Ratio1:=AFont.PixelsPerInch / 2540;
      DC:=GetDC(0);
      fhGDI:=SelectObject(DC,AFont.Handle);
      AText:='中';
      GetTextExtentPoint32(DC,PChar(AText),Length(AText),ASize);
      W:=Round(ASize.cx-1);///Ratio1);
      H:=Round(ASize.cy);///Ratio1);
      AText:='A';
      GetTextExtentPoint32(DC,PChar(AText),Length(AText),ASize);
      EW:=Round(ASize.cx);///Ratio1);
      SelectObject(DC,fhGDI);
    finally
      AFont.Free;
      ReleaseDC(0,DC);
    end;
  end;
{var
  i,j:integer;
  H,GW,EW:integer;
  s,vs:widestring;
  vPdfRect:TPdfRect;
  zLeft,zTop,zRight,zBottom:integer;
  sb:string;
begin
  with ACanvas.PdfCanvas do
  begin
    //SetFont(GetFontClassName, FontSize);
    SetRGBFillColor(FontColor);
    SetCharSpace(CharSpace);
    SetWordSpace(WordSpace);
    SetLeading(Leading);
    GetFontMMSize('宋体',Round(FontSize),H,GW,EW);
    zTop   :=GetPage.Height- ARect.Top;
    for i:= Lines.Count-1 downto 0 do
    begin
      zLeft  :=ARect.Left;
      zRight :=ARect.Right;
      zBottom:=GetPage.Height- ARect.Bottom;
      s:=Lines.Strings[i];
      for j:=1 to length(s) do
      begin
        sb:=s[j];
        if length(sb)=2 then
        begin
          zLeft:=zLeft+GW;
          SetFont('Chinese', FontSize);
        end
        else begin
          zLeft:=zLeft+EW;
          SetFont(GetFontClassName, FontSize);
        end;
        vPdfRect:= _PdfRect(zLeft,zTop,zRight,zBottom);
        MultilineTextRect(vPdfRect,s[j], WordWrap);
      end;
      zTop   :=zTop+H;
    end;
  end;}
var
  i:integer;
  H,GW,EW:integer;
begin
  with ACanvas.PdfCanvas do
  begin
    SetFont(GetFontClassName, FontSize);
    SetRGBFillColor(FontColor);
    SetCharSpace(CharSpace);
    SetWordSpace(WordSpace);
    SetLeading(Leading);
    with ARect do
    begin
      MultilineTextRect(_PdfRect(Left, GetPage.Height- Top, Right, GetPage.Height- Bottom),
        Text, WordWrap);
    end;
  end;
end;

// SetCharSpace
procedure TPRCustomLabel.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;

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