preport.pas

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

end;

procedure TPRCanvas.SetHorizontalScaling(hScaling: Word);
begin
  PdfCanvas.SetHorizontalScaling(hScaling);
end;

procedure TPRCanvas.SetLeading(leading: Single);
begin
  PdfCanvas.SetLeading(leading);
end;

procedure TPRCanvas.SetFontAndSize(fontname: string; size: Single);
begin
  PdfCanvas.SetFontAndSize(fontname, size);
end;

procedure TPRCanvas.SetTextRenderingMode(mode: TTextRenderingMode);
begin
  PdfCanvas.SetTextRenderingMode(mode);
end;

procedure TPRCanvas.SetTextRise(rise: Word);
begin
  PdfCanvas.SetTextRise(rise);
end;


{ TPRPage }

// Create
constructor TPRPage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := PDF_DEFAULT_PAGE_WIDTH;
  Height := PDF_DEFAULT_PAGE_HEIGHT;
  FMarginTop := DEFAULT_MARGIN;
  FMarginLeft := DEFAULT_MARGIN;
  FMarginRight := DEFAULT_MARGIN;
  FMarginBottom := DEFAULT_MARGIN;
  FDoc := TPdfDoc.Create(Self);
  FDoc.NewDoc;
  FDoc.AddPage;
end;

// Destroy
destructor TPRPage.Destroy;
begin
  FDoc.Free;
  inherited;
end;

// AlignControls
procedure TPRPage.AlignControls(AControl: TControl; var ARect: TRect);
begin
  ARect := Rect(ARect.Left + FMarginLeft, ARect.Top + FMarginTop,
    ARect.Right - FMarginRight, ARect.Bottom - FMarginBottom);
  inherited AlignControls(AControl, ARect);
end;

// Paint
procedure TPRPage.Paint;
var
  LinePos: integer;
  LineCount: Integer;
begin
  inherited Paint;

  with Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(GetClientRect);
    PaintGrid(Canvas, Width, Height, 0, 0);
    Font.Size := 8;
    Font.Color := clSilver;

    LineCount := 0;
    LinePos := 0;
    while LinePos < Width do
    begin
      TextOut(LinePos + 1, 1, IntToStr(LineCount));
      inc(LineCount);
      LinePos := trunc(LineCount * LINE_PITCH / 10);
    end;
    LineCount := 0;
    LinePos := 0;
    while LinePos < Height do
    begin
      TextOut(1, LinePos + 1, IntToStr(LineCount));
      inc(LineCount);
      LinePos := trunc(LineCount * LINE_PITCH / 10);
    end;

    Font := Self.Font;
    TextOut(4, 4, Name);
  end;
end;

// Print
procedure TPRPage.Print(ACanvas: TPRCanvas);
var
  i: integer;
begin
  with ACanvas.PdfCanvas do
  begin
    PageHeight := Height;
    PageWidth := Width;
  end;
  if Assigned(FPrintPageEvent) then
    FPrintPageEvent(Self, ACanvas);
  for i := 0 to ControlCount - 1 do
  begin
    if (Controls[i] is TPRPanel) then
      with (Controls[i] as TPRPanel) do
        Print(ACanvas, BoundsRect);
  end;
end;

// SetMarginTop
procedure TPRPage.SetMarginTop(Value: integer);
var
  Rect: TRect;
begin
  if (FMarginTop <> Value) and (Value > 0) and (Value < Width div 2) then
  begin
    Rect := ClientRect;
    FMarginTop := Value;
    AlignControls(nil, Rect);
  end;
end;

// SetMarginLeft
procedure TPRPage.SetMarginLeft(Value: integer);
var
  Rect: TRect;
begin
  if (FMarginLeft <> Value) and (Value > 0) and (Value < Width div 2) then
  begin
    Rect := ClientRect;
    FMarginLeft := Value;
    AlignControls(nil, Rect);
  end;
end;

// SetMarginRight
procedure TPRPage.SetMarginRight(Value: integer);
var
  Rect: TRect;
begin
  if (FMarginRight <> Value) and (Value > 0) and (Value < Width div 2) then
  begin
    Rect := ClientRect;
    FMarginRight := Value;
    AlignControls(nil, Rect);
  end;
end;

// SSetMarginBottom
procedure TPRPage.SetMarginBottom(Value: integer);
var
  Rect: TRect;
begin
  if (FMarginBottom <> Value) and (Value > 0) and (Value < Width div 2) then
  begin
    Rect := ClientRect;
    FMarginBottom := Value;
    AlignControls(nil, Rect);
  end;
end;

{ TPRPanel }

// Create
constructor TPRPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  Align := alTop;
  Height := 100;
  BevelOuter := bvNone;
  Color := clWindow;
  BorderStyle := bsNone;
end;

// GetPage
function TPRPanel.GetPage: TPRPage;
begin
  if (Parent is TPRPage) then
    result := TPRPage(Parent)
  else
    result := (Parent as TPRPanel).GetPage;
end;

// Paint
procedure TPRPanel.Paint;
var
  TmpRect: TRect;
begin
  with Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(Rect(0,0,Width,Height));
    TmpRect := GetAbsoluteRect;
    PaintGrid(Canvas, Width, Height, TmpRect.Left, TmpRect.Top);
    TextOut(2, 2, Name);
    Pen.Color := clGreen;
    Pen.Style := psDot;
    MoveTo(0,0);
    LineTo(Width-1,0);
    LineTo(Width-1,Height-1);
    LineTo(0,Height-1);
    LineTo(0,0);
  end;
end;

// GetAbsoluteRect
function TPRPanel.GetAbsoluteRect: TRect;
begin
  // return absolute position which based on TPRPage.
  if (Parent is TPRPanel) then
  begin
    result := TPRPanel(Parent).GetAbsoluteRect;
    OffsetRect(result, Left, Top);
  end
  else
    result := Rect(Left, Top, Left+Width, Top+Height);
end;

// Print
procedure TPRPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  i: integer;
  tmpRect: TRect;
begin
  for i := 0 to ControlCount - 1 do
  begin
    tmpRect := Controls[i].BoundsRect;
    OffsetRect(tmpRect, ARect.Left, ARect.Top);
    if (Controls[i] is TPRPanel) then
      TPRPanel(Controls[i]).Print(ACanvas, tmpRect)
    else
    if (Controls[i] is TPRItem) then
      TPRItem(Controls[i]).Print(ACanvas, tmpRect);
  end;
end;

{ TPRLayoutPanel }

// SetParent
procedure TPRLayoutPanel.SetParent(AParent: TWinControl);
begin
  if (AParent <> nil) and
   (not (AParent is TPRPanel) and not (AParent is TPRPage)) then
    raise Exception.Create('TPRPage can not set on ' + AParent.ClassName);
  if (AParent is TPRGridPanel) then
    AParent := TPRGridPanel(AParent).FChildPanel;
  inherited SetParent(AParent);
end;

// Print
procedure TPRLayoutPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
begin
  if Assigned(FBeforePrint) then
    FBeforePrint(Self, ACanvas, ARect);
  inherited Print(ACanvas, ARect);
  if Assigned(FAfterPrint) then
    FAfterPrint(Self, ACanvas, ARect);
end;

{ TPRGridPanel }

// Create
constructor TPRGridPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColCount := 1;
  FRowCount := 1;
  FChildPanel := TPRChildPanel.Create(Self);
  FChildPanel.Align := alClient;
  FChildPanel.Parent := Self;
end;

// Destroy
destructor TPRGridPanel.Destroy;
begin
  FChildPanel.Free;
  inherited;
end;

// GetChildParent
function TPRGridPanel.GetChildParent: TComponent;
begin
  Result := FChildPanel;
end;

// GetChildren
procedure TPRGridPanel.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
  FChildPanel.GetChildren(Proc, Root);
end;

// AlignControls
procedure TPRGridPanel.AlignControls(AControl: TControl; var ARect: TRect);
begin
  if FColCount > 1 then
    ARect.Right := ARect.Left + (ARect.Right-ARect.Left) div ColCount;
  if FRowCount > 1 then
    ARect.Bottom := ARect.Top + (ARect.Bottom-ARect.Top) div RowCount;
  inherited AlignControls(AControl, ARect);
end;

// SetColCount
procedure TPRGridPanel.SetColCount(Value: integer);
var
  Rect: TRect;
begin
  if Value <> FColCount then
  begin
    if (Value < 1) or ((Width div Value) < MIN_PANEL_SIZE) then
      raise Exception.Create('invalid colcount');
    FColCount := Value;
    Rect := GetClientRect;
    AlignControls(nil, Rect);
    Invalidate;
  end;
end;

// SetRowCount
procedure TPRGridPanel.SetRowCount(Value: integer);
var
  Rect: TRect;
begin
  if Value <> FRowCount then
  begin
    if (Value < 1) or ((Height div Value) < MIN_PANEL_SIZE) then
      raise Exception.Create('invalid rowcount');
    FRowCount := Value;
    Rect := GetClientRect;
    AlignControls(nil, Rect);
    Invalidate;
  end;
end;

// Paint
procedure TPRGridPanel.Paint;
var
  TmpRect: TRect;
  TmpWidth, TmpHeight: integer;
  i: integer;
begin
  with Canvas do
  begin
    if (FColCount > 1) or (FRowCount > 1) then
    begin
      Brush.Color := PROTECT_AREA_COLOR;
      FillRect(GetClientRect);
    end;
    TmpWidth := Trunc(Width / FColCount);
    TmpHeight := Trunc(Height / FRowCount);
    Brush.Color := clWhite;
    FillRect(Rect(0,0,TmpWidth,TmpHeight));
    TmpRect := GetAbsoluteRect;
    PaintGrid(Canvas, Width, Height, TmpRect.Left, TmpRect.Top);

    // draw ruled line
    Pen.Color := clBlue;
    Pen.Style := psDot;
    for i := 0 to FRowCount do
    begin
      TmpHeight := Trunc(Height*i/FRowCount);
      if TmpHeight = Height then
        dec(TmpHeight);
      MoveTo(0,TmpHeight);
      LineTo(Width,TmpHeight);
    end;
    for i := 0 to FColCount do
    begin
      TmpWidth := Trunc(Width*i/FColCount);
      if TmpWidth = Width then
        dec(TmpWidth);
      MoveTo(TmpWidth,0);
      LineTo(TmpWidth,Height);
    end;

    FChildPanel.Repaint;
  end;
end;

// Print
procedure TPRGridPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
var
  i, j: integer;

  procedure PrintSubPanel(ACol, ARow: integer);
  var
    tmpRect: TRect;
    OffsetY, OffsetX: Integer;
  begin
    tmpRect := ARect;
    OffsetY := Trunc(Height * ARow / FRowCount);
    OffsetX := Trunc(Width * ACol / FColCount);
    tmpRect.Right := tmpRect.Left + FChildPanel.Width;
    tmpRect.Bottom := tmpRect.Top + FChildPanel.Height;
    OffsetRect(tmpRect, OffsetX, OffsetY);
    if Assigned(FBeforePrintChild) then
      FBeforePrintChild(Self, ACanvas, ACol, ARow, tmpRect);
    FChildPanel.Print(ACanvas, tmpRect);
    if Assigned(FAfterPrintChild) then
      FAfterPrintChild(Self, ACanvas, ACol, ARow, tmpRect);
  end;
begin
  if Assigned(FBeforePrint) then
    FBeforePrint(Self, ACanvas, ARect);
  // printing FChildPanel each row and col.
  if FPrintDirection = pdVert then
    for i := 0 to FColCount - 1 do
      for j := 0 to FRowCount - 1 do
        PrintSubPanel(j, i)
  else
    for j := 0 to FRowCount - 1 do
      for i := 0 to FColCount - 1 do
        PrintSubPanel(i, j);
  if Assigned(FAfterPrint) then
    FAfterPrint(Self, ACanvas, ARect);
end;

// SetParent
procedure TPRGridPanel.SetParent(AParent: TWinControl);
begin
  if (AParent <> nil) and
   (not (AParent is TPRPanel) and not (AParent is TPRPage)) then
    raise Exception.Create('TPRPage can not set on ' + AParent.ClassName);
  inherited SetParent(AParent);
end;

{ TPRItem }

constructor TPRItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 100;
  Height := 30;
  FPrintable := true;
end;

// SetParent
procedure TPRItem.SetParent(AParent: TWinControl);
begin
  if (AParent <> nil) and
   (not (AParent is TPRPanel)) then
    raise Exception.Create('this component must set on TPRPanel');
  if (AParent is TPRGridPanel) then
    AParent := TPRGridPanel(AParent).FChildPanel;
  inherited SetParent(AParent);
end;

// Print
procedure TPRItem.Print(ACanvas: TPRCanvas; ARect: TRect);
begin
  // abstract method..
end;

// GetPage
function TPRItem.GetPage: TPRPage;
begin
  result := (Parent as TPRPanel).Page;
end;

{ TPRText }

// GetInternalDoc
function TPRText.GetInternalDoc: TPdfDoc;
begin
  result := Page.FDoc;
end;

// 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);
  Canvas.Brush.Style := bsClear;
  FFontName := fnArial;
  FFontSize := 12;
  FFontBold := false;
  FFontItalic := false;
  FLeading := 14;
  {$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);
  FLines := TStringList.Create;
  ParentFont := false;
end;

// Destroy
destructor TPRText.Destroy;
begin
  FLines.Free;
  inherited;
end;

// SetFontName
procedure TPRText.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 TPRText.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 TPRText.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 TPRText.SetFontSize(Value: Single);
begin
  if (FFontSize <> Value) and (Value > 0) then
  begin
    FFontSize := Value;
    Font.Size := Round(Value*0.75);
    Invalidate;
  end;
end;

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

// GetNextWord
function TPRText.GetNextWord(const S: string;
  var Index: integer): string;