wateru2.pas

wptools5 pro 完整源代码 Msword界面的文本编辑器源代码

unit WaterU2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, WPRTEDefs, WPRTEPaint, WPCTRMemo, WPCTRRich, ComCtrls,
  ExtCtrls, WPUtil, WpPagPrp;

type
  TWaterM2Demo = class(TForm)
    WPRichText1: TWPRichText;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    NameE: TEdit;
    AdrE: TEdit;
    Cost: TLabel;
    CostE: TEdit;
    Print: TButton;
    PageFormat: TButton;
    WPPagePropDlg1: TWPPagePropDlg;
    DrawDebugCross: TCheckBox;
    Image1: TImage;
    FormatToPrinter: TCheckBox;
    procedure CostEChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure WPRichText1MailMergeGetText(Sender: TObject;
      const inspname: string; Contents: TWPMMInsertTextContents);
    procedure WPRichText1MeasureTextPage(Sender: TObject;
      PageInfo: TWPMeasurePageParam);
    procedure WPRichText1PaintWatermark(Sender: TObject;
      RTFEngine: TWPRTFEnginePaint; toCanvas: TCanvas; PageRect: TRect;
      PaintPageNr, RTFPageNr: Integer; WaterMarkRef: TObject; XRes,
      YRes: Integer; CurrentZoom: Single; PaintMode: TWPPaintModes);
    procedure PrintClick(Sender: TObject);
    procedure PageFormatClick(Sender: TObject);
    procedure DrawDebugCrossClick(Sender: TObject);
    procedure FormatToPrinterClick(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    procedure PrintTiledBackground(toCanvas : TCanvas; PageRect : TRect; Mult : Double = 1);
  end;

var
  WaterM2Demo: TWaterM2Demo;

const PR_Form_Height = 10.5; // Form Height in CM
      PR_Form_Width  = 15.0;

implementation

{$R *.dfm}

procedure TWaterM2Demo.FormShow(Sender: TObject);
begin
  // Non Standard PROPS:
  WPRichText1.InsertPointAttr.Hidden := TRUE;
  WPRichText1.AutoZoom := wpAutoZoomWidth; // from unit WPRTEPaint

  WPRichText1.MergeText;
end;

procedure TWaterM2Demo.PrintClick(Sender: TObject);
begin
   WPRichText1.PrintDialog;
end;

procedure TWaterM2Demo.DrawDebugCrossClick(Sender: TObject);
begin
   WPRichText1.Repaint; // Invalidate does not work here since the screen is buffered
end;

procedure TWaterM2Demo.PageFormatClick(Sender: TObject);
begin
  WPPagePropDlg1.Execute;
end;

procedure TWaterM2Demo.CostEChange(Sender: TObject);
begin
  WPRichText1.MergeText;
end;


procedure TWaterM2Demo.WPRichText1MailMergeGetText(Sender: TObject;
  const inspname: string; Contents: TWPMMInsertTextContents);
begin
  if inspname = 'NAME' then Contents.StringValue := NameE.Text
  else if inspname = 'ADR' then Contents.StringValue := AdrE.Text;

end;

procedure TWaterM2Demo.WPRichText1MeasureTextPage(Sender: TObject;
  PageInfo: TWPMeasurePageParam);
begin
  // We want to make sure the first page has a bottom margin which is
  // large enough for our form
  if PageInfo.pagenr = 1 then
  begin
    PageInfo.marginbottom := WPCentimeterToTwips(PR_Form_Height);
    PageInfo.changed := TRUE;
  end;
end;

procedure TWaterM2Demo.WPRichText1PaintWatermark(Sender: TObject;
  RTFEngine: TWPRTFEnginePaint; toCanvas: TCanvas; PageRect: TRect;
  PaintPageNr, RTFPageNr: Integer; WaterMarkRef: TObject; XRes,
  YRes: Integer; CurrentZoom: Single; PaintMode: TWPPaintModes);
  // ~~~~~~~~~~~~~~~~~~~~~ Convert CM values into pixel ~~~~~~~~~~~~~
  function XP(cm: Double): Integer;
  begin
    Result := MulDiv(WPCentimeterToTwips(cm), Xres, 1440);
  end;
  function YP(cm: Double): Integer;
  begin
    Result := MulDiv(WPCentimeterToTwips(cm), Yres, 1440);
  end;
  // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
var r, r2: TRect;
  off, w: Integer;
  i, j : Integer;
begin
  if PaintPageNr = 0 then
  begin
    r := PageRect;
    r.Top := r.Bottom - YP(PR_Form_Height);
    toCanvas.Pen.Color := clBlack;
    toCanvas.Pen.Style := psSolid;
    toCanvas.Pen.Width := XRes div 60; // width = 1/60 INCH

    // WPDrawDashes draws a dashed line with a distance of 1/8 inch (inchdivisor)
    // between dashes (Reason to use WPDrawDashes(): psDash is not printed well)
    WPDrawDashes( toCanvas, XRes, r.TopLeft, Point(r.Right, r.Top));

    // Draw the form at the right bottom border
    r.Left := r.Right - XP(PR_Form_Width);

    // Draw line
    WPDrawDashes( toCanvas, XRes, r.TopLeft, Point(r.Left, r.Bottom));

    // Reset Pen Width
    toCanvas.Pen.Width := 0;

    // Draw the sizzors
    toCanvas.Font.Name := 'WingDings';
    toCanvas.Font.Height := -YP(0.5);
    toCanvas.TextOut( PageRect.Left + XP(0.9), r.Top-
       toCanvas.TextHeight(#$22) div 2 , #$22 );

     // This is background of the form, we do not draw this when
     // we are printing!
    if wppInPaintDesktop in PaintMode then
    begin
      r2 := r;
      inc(r2.Left,XP(0.1));
      inc(r2.Top,YP(0.1));
      toCanvas.Brush.Color := clYellow;
      toCanvas.FillRect(r2);
    end;

     // This are the form text
    toCanvas.Brush.Color := clWhite;
    toCanvas.Font.Name := 'Courier New';
    toCanvas.Font.Height := -YP(0.5);
    toCanvas.Font.Style := [fsBold];
    off := YP(0.1);

     // NAME
    r2.Left := r.Left + XP(1.0);
    r2.Top := r.Top + YP(2);
    r2.Right := r2.Left + XP(10);
    r2.Bottom := r2.Top + YP(0.7);
    toCanvas.FillRect(r2);
    toCanvas.TextOut(r2.Left + off, r2.Top + off, NameE.Text);

     // ADR
    r2.Left := r.Left + XP(1.0);
    r2.Top := r.Top + YP(5.5);
    r2.Right := r2.Left + XP(10);
    r2.Bottom := r2.Top + YP(0.7);
    toCanvas.FillRect(r2);
    toCanvas.TextOut(r2.Left + off, r2.Top + off, AdrE.Text);

     // COST, right aligned
    r2.Left := r.Left + XP(8.5);
    r2.Top := r.Top + YP(4.5);
    r2.Right := r2.Left + XP(5);
    r2.Bottom := r2.Top + YP(0.7);
    toCanvas.FillRect(r2);
    w := toCanvas.TextWidth(CostE.Text);
    toCanvas.TextOut(r2.Right - off - w, r2.Top + off, CostE.Text);

    // For Debugging
    // Draw a Line at 10,10 CM
    if DrawDebugCross.Checked then
    begin
    toCanvas.TextOut( PageRect.Left+XP(10), PageRect.Top, '10');
    toCanvas.TextOut( PageRect.Left, PageRect.Top+YP(10), '10');
    toCanvas.MoveTo( PageRect.Left, PageRect.Top + YP(10));
    toCanvas.LineTo( PageRect.Right, PageRect.Top + YP(10));
    toCanvas.MoveTo( PageRect.Left+XP(10), PageRect.Top);
    toCanvas.LineTo( PageRect.Left+XP(10), r.Top);
    end;
  end else
  // Draw and Print a Grid
  if PaintPageNr = 1 then
  begin
    toCanvas.Pen.Width := 0;
    toCanvas.Pen.Color := $00FAD5AF;
    toCanvas.Pen.Style := psSolid;
    for i:=1 to 1000 do
    begin
      j := PageRect.Left + MulDiv(WPCentimeterToTwips(0.5 * i), Xres, 1440);
      if j>= PageRect.Right then break;
      toCanvas.MoveTo(j, PageRect.Top);
      toCanvas.LineTo(j, PageRect.Bottom);
    end;

    for i:=1 to 1000 do
    begin
      j := PageRect.Top + MulDiv(WPCentimeterToTwips(0.5 * i), Yres, 1440);
      if j>= PageRect.Bottom then break;
      toCanvas.MoveTo(PageRect.Left, j);
      toCanvas.LineTo(PageRect.Right, j);
    end;
  end
  // Display a tiled background only on screen
  else if wppInPaintDesktop in PaintMode then
      PrintTiledBackground(toCanvas,PageRect, XRes / Screen.PixelsPerInch); 
end;

{ This procedure draws a tiled background.
  Optionally a w/h multiplicator can be provided. This is required to see the same
  display on different resolutions } 

procedure TWaterM2Demo.PrintTiledBackground(toCanvas : TCanvas; PageRect : TRect; Mult : Double = 1);
var x,y : Integer;
    bit : TBitmap;
begin
    x := PageRect.Left;
    bit := Image1.Picture.Bitmap;
    if Abs(Mult-1)<0.01 then
    while x<PageRect.Right do
    begin
     y := PageRect.Top;
     while y<PageRect.Bottom do
     begin
       toCanvas.Draw(x,y,bit);
       inc(y, bit.Height);
     end;
     inc(x, bit.Width);
    end else
    while x<PageRect.Right do
    begin
     y := PageRect.Top;
     while y<PageRect.Bottom do
     begin
       toCanvas.StretchDraw(Rect(x,y, Round(x + bit.Width * mult), Round(y + bit.Height * mult)),bit);
       inc(y, Round(bit.Height*mult));
     end;
     inc(x, Round(bit.Width*mult));
    end
end;




procedure TWaterM2Demo.FormatToPrinterClick(Sender: TObject);
begin
   WPRichText1.Memo.RTFData.UpdateReformatMode(
       FormatToPrinter.Checked
      );
   WPRichText1.Repaint;
end;

end.