preport.pas

给PDF文件加盖印章或背景

  begin
    FWordwrap := Value;
    Invalidate;
  end;
end;

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

{ TPRShape }

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

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

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

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

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

// SetDash
procedure TPRShape.SetDash(ACanvas: TPdfCAnvas; APattern: TPenStyle);
begin
  // emurate TPenStyle
  with ACanvas 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;


{ TPRRect }

// 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;
begin
  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(ACanvas.PdfCanvas, 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;

{ TPREllipse }

// Paint
procedure TPREllipse.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;
    end
    else
      Brush.Style := bsClear;

    if (LineColor <> clNone) and (LineStyle <> psClear) then
    begin
      Pen.Style := FLineStyle;
      Pen.Width := Round(FLineWidth);
      Pen.Color := FLineColor;
    end
    else
      Pen.Style := psClear;

    Ellipse(Left, Top, Right, Bottom);
  end;
end;

// Print
procedure TPREllipse.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  PageHeight: integer;
begin
  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(ACanvas.PdfCanvas, FLineStyle);

    with ACanvas.PdfCanvas do
    begin
      with ARect do
        Ellipse(Left, Top, Right - Left, Bottom - Top);

      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) then
    with Canvas do
    begin
      Brush.Style := bsClear;
      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
  if FStretch then
    Canvas.StretchDraw(GetClientRect, FPicture.Graphic)
  else
    Canvas.Draw(0, 0, FPicture.Graphic);
end;

// Print
procedure TPRImage.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  FDoc: TPdfDoc;
  FXObjectName: string;
  i: integer;
  FIdx: integer;
begin
  if (FPicture = nil) or (FPicture.Graphic = nil) or
   (FPicture.Graphic.Empty) or not (FPicture.Graphic is TBitmap) then
    Exit;
  FDoc := ACanvas.PdfCanvas.Doc;
  if SharedImage then
  begin
    FXObjectName := Self.Name;
    if FDoc.GetXObject(FXObjectName) = nil then
      FDoc.AddXObject(FXObjectName, CreatePdfImage(FPicture.Graphic, 'Pdf-Bitmap'));
  end
  else
  begin
    FIdx := Random(MAX_IMAGE_NUMBER - 1);
    for i := 0 to MAX_IMAGE_NUMBER - 1 do
    begin
      FXObjectName := Self.Name + IntToStr(FIdx);
      if FDoc.GetXObject(FXObjectName) = nil then Break;
      if i = MAX_IMAGE_NUMBER then
        raise Exception.Create('image count over max value..');
      inc(FIdx);
      if FIdx >= MAX_IMAGE_NUMBER then
        FIdx := 0;
    end;
    FDoc.AddXObject(FXObjectName, CreatePdfImage(FPicture.Graphic, 'Pdf-Bitmap'));
  end;
  with ARect, ACanvas.PdfCanvas do
    if FStretch then
      DrawXObject(Left, GetPage.Height - Bottom, Width, Height, FXObjectName)
    else
      DrawXObjectEx(Left, GetPage.Height - Top - FPicture.Height,
            FPicture.Width, FPicture.Height,
            Left, GetPage.Height - Top - Height, Width, Height, FXObjectName);
end;

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

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

// SetStretch
procedure TPRImage.SetStretch(Value: boolean);
begin
  if Value = FStretch then Exit;
  FStretch := Value;
  Invalidate;
end;

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

{ TPRDestination }
procedure TPRDestination.SetType(Value: TPRDestinationType);
begin
  FData.DestinationType := Value;
end;

function TPRDestination.GetType: TPRDestinationType;
begin
  result := FData.DestinationType;
end;

procedure TPRDestination.SetElement(Index: integer; Value: Integer);
begin
  case Index of
    0: FData.Left := Value;
    1: FData.Top := FData.PageHeight - Value;
    2: FData.Right := Value;
    3: FData.Bottom := FData.PageHeight - Value;
  end;
end;

procedure TPRDestination.SetZoom(Value: Single);
begin
  FData.Zoom := Value;
end;

function TPRDestination.GetElement(Index: integer): Integer;
begin
  case Index of
    0: Result := FData.Left;
    1: Result := FData.Top;
    2: Result := FData.Right;
  else
    Result := FData.Bottom;
  end;
end;

function TPRDestination.GetZoom: Single;
begin
  Result := FData.Zoom;
end;

constructor TPRDestination.Create(AData: TPdfDestination);
begin
  inherited Create;
  FData := AData;
  AData.Reference := Self;
end;

{ TPROutlineEntry }
function TPROutlineEntry.GetParent: TPROutlineEntry;
begin
  if FData.Parent <> nil then
    Result := TPROutlineEntry(FData.Parent.Reference)
  else
    Result := nil;
end;

function TPROutlineEntry.GetNext: TPROutlineEntry;
begin
  if FData.Next <> nil then
    Result := TPROutlineEntry(FData.Next.Reference)
  else
    Result := nil;
end;

function TPROutlineEntry.GetPrev: TPROutlineEntry;
begin
  if FData.Prev <> nil then
    Result := TPROutlineEntry(FData.Prev.Reference)
  else
    Result := nil;
end;

function TPROutlineEntry.GetFirst: TPROutlineEntry;
begin
  if FData.First <> nil then
    Result := TPROutlineEntry(FData.First.Reference)
  else
    Result := nil;
end;

function TPROutlineEntry.GetLast: TPROutlineEntry;
begin
  if FData.Last <> nil then
    Result := TPROutlineEntry(FData.Last.Reference)
  else
    Result := nil;
end;

function TPROutlineEntry.GetDest: TPRDestination;
begin
  if FData.Dest <> nil then
    Result := TPRDestination(FData.Dest.Reference)
  else