fr_rxrtf.pas

FASTREPORT报表工具,可以迅速制作报表.

{******************************************}
{                                          }
{             FastReport v2.4              }
{          RxRich Add-In Object            }
{                                          }
{ Copyright (c) 1998-2001 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_RxRTF;

interface

{$I FR.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Menus,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls,
  FR_DBRel, FR_Class, RichEdit, RxRiched, FR_Ctrls, FR_Combo;

type
  TfrRxRichObject = class(TComponent)  // fake component
  end;

  TfrRxRichView = class(TfrStretcheable)
  private
    CurChar, LastChar, CharFrom: Integer;
    Flag: Boolean;
    procedure P1Click(Sender: TObject);
    procedure GetRichData(ASource: TCustomMemo);
    function DoCalcHeight: Integer;
    procedure ShowRich(Render: Boolean);
    procedure RichEditor(Sender: TObject);
  protected
    procedure SetPropValue(Index: String; Value: Variant); override;
    function GetPropValue(Index: String): Variant; override;
  public
    RichEdit: TRxRichEdit;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure GetBlob(b: TfrTField); override;
    function CalcHeight: Integer; override;
    function MinHeight: Integer; override;
    function LostSpace: Integer; override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  TfrRxRichForm = class(TForm)
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    SpeedBar: TPanel;
    OpenButton: TfrSpeedButton;
    SaveButton: TfrSpeedButton;
    UndoButton: TfrSpeedButton;
    Ruler: TPanel;
    FontDialog1: TFontDialog;
    FirstInd: TLabel;
    LeftInd: TLabel;
    RulerLine: TBevel;
    RightInd: TLabel;
    BoldButton: TfrSpeedButton;
    ItalicButton: TfrSpeedButton;
    LeftAlign: TfrSpeedButton;
    CenterAlign: TfrSpeedButton;
    RightAlign: TfrSpeedButton;
    UnderlineButton: TfrSpeedButton;
    BulletsButton: TfrSpeedButton;
    RichEdit1: TRxRichEdit;
    SpeedButton1: TfrSpeedButton;
    CancBtn: TfrSpeedButton;
    OkBtn: TfrSpeedButton;
    SpeedButton2: TfrSpeedButton;
    Image1: TImage;
    Bevel1: TBevel;
    HelpBtn: TfrSpeedButton;
    FontName: TfrFontComboBox;
    FontSize: TfrComboBox;

    procedure SelectionChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FileOpen(Sender: TObject);
    procedure FileSaveAs(Sender: TObject);
    procedure EditUndo(Sender: TObject);
    procedure SelectFont(Sender: TObject);
    procedure RulerResize(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure BoldButtonClick(Sender: TObject);
    procedure AlignButtonClick(Sender: TObject);
    procedure FontNameChange(Sender: TObject);
    procedure BulletsButtonClick(Sender: TObject);
    procedure RulerItemMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure RulerItemMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FirstIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure LeftIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure RightIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure CancBtnClick(Sender: TObject);
    procedure OkBtnClick(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure HelpBtnClick(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FontSizeChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    FUpdating: Boolean;
    FDragOfs: Integer;
    FDragging: Boolean;
    function CurrText: TRxTextAttributes;
    procedure SetupRuler;
    procedure SetEditRect;
    procedure Localize;
  public
  end;


implementation

uses FR_Pars, FR_Intrp, FR_Utils, FR_Const, Printers
{$IFDEF Delphi6}
, Variants
{$ENDIF};

const
  RulerAdj = 4/3;
  GutterWid = 6;

{$R *.DFM}


var
  SRichEdit: TRxRichEdit; // temporary rich used during TRichView drawing
  frRxRichForm: TfrRxRichForm;

procedure AssignRich(Rich1, Rich2: TRxRichEdit);
var
  st: TMemoryStream;
begin
  st := TMemoryStream.Create;
  Rich2.Lines.SaveToStream(st);
  st.Position := 0;
  Rich1.Lines.LoadFromStream(st);
  st.Free;
end;

{----------------------------------------------------------------------------}
constructor TfrRxRichView.Create;
begin
  inherited Create;
  RichEdit := TRxRichEdit.Create(nil);
  RichEdit.Parent := frRxRichForm;
  RichEdit.Visible := False;
  BaseName := 'RxRich';
end;

destructor TfrRxRichView.Destroy;
begin
  if frRxRichForm <> nil then RichEdit.Free;
  inherited Destroy;
end;

procedure TfrRxRichView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Lines', [frdtHasEditor, frdtOneObject], RichEditor);
  AddProperty('Stretched', [frdtBoolean], nil);
  AddProperty('TextOnly', [frdtBoolean], nil);
  AddProperty('GapX', [frdtInteger], nil);
  AddProperty('GapY', [frdtInteger], nil);
  AddProperty('DataField', [frdtOneObject, frdtHasEditor, frdtString], frFieldEditor);
end;

procedure TfrRxRichView.SetPropValue(Index: String; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'TEXTONLY' then
    Flags := (Flags and not flTextOnly) or Word(Boolean(Value)) * flTextOnly
end;

function TfrRxRichView.GetPropValue(Index: String): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'TEXTONLY' then
    Result := (Flags and flTextOnly) <> 0
end;

function GetSpecial(const s: String; Pos: Integer): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 1 to Pos do
    if s[i] in [#10, #13] then
      Inc(Result);
end;

procedure TfrRxRichView.GetRichData(ASource: TCustomMemo);
var
  R, S: String;
  i, j: Integer;
begin
  CurView := Self;
  with ASource do
  try
    Lines.BeginUpdate;
    i := Pos('[', Text);
    while i > 0 do
    begin
      SelStart := i - 1 - GetSpecial(Text, i) div 2;
      R := GetBrackedVariable(Text, i, j);
      CurReport.InternalOnGetValue(R, S);
      SelLength := j - i + 1;
      SelText := S;
      i := Pos('[', Text);
    end;
  finally
    Lines.EndUpdate;
  end;
end;

function TfrRxRichView.DoCalcHeight: Integer;
var
  Range: TFormatRange;
  MaxLen, LogX, LogY: Integer;
begin
  FillChar(Range, SizeOf(TFormatRange), 0);
  with Range do
  begin
    hdc := GetDC(0);
    hdcTarget := hdc;
    LogX := Screen.PixelsPerInch;
    LogY := LogX;

    rc := Rect(0, 0, Round((DX - GapX * 2) * 1440 / LogX), Round(1000000 * 1440.0 / LogY));
    rcPage := rc;
    LastChar := CharFrom;
    MaxLen := SRichEdit.GetTextLen;
    chrg.cpMin := LastChar;
    chrg.cpMax := -1;
    SRichEdit.Perform(EM_FORMATRANGE, 0, Integer(@Range));
    ReleaseDC(0, hdc);
    if MaxLen = 0 then
      Result := 0
    else
    begin
      if (rcPage.bottom <> rc.bottom) then
        Result := Round(rc.bottom / (1440.0 / LogY)) + 2 * GapY else
        Result := 0;
    end;
  end;
  SRichEdit.Perform(EM_FORMATRANGE, 0, 0);
end;

{$WARNINGS OFF}
procedure TfrRxRichView.ShowRich(Render: Boolean);
var
  Range: TFormatRange;
  LogX, LogY, mm: Integer;
  EMF: TMetafile;
  EMFCanvas: TMetafileCanvas;
  re: TRxRichEdit;
  BMP: TBitmap;
begin
  if Render then
    re := RichEdit else
    re := SRichEdit;
  FillChar(Range, SizeOf(TFormatRange), 0);
  with Range do
  begin
    if Render then
      hdc := Canvas.Handle else
      hdc := GetDC(0);
    if Render then
      if IsPrinting then
      begin
        LogX := GetDeviceCaps(hdc, LOGPIXELSX);
        LogY := GetDeviceCaps(hdc, LOGPIXELSY);
        rc := Rect(DRect.Left * 1440 div LogX, DRect.Top * 1440 div LogY,
                   DRect.Right * 1440 div LogX, Round(DRect.Bottom * 1440 / LogY));
      end
      else
      begin
        LogX := Screen.PixelsPerInch;
        LogY := LogX;
        rc := Rect(0, 0, Round((SaveDX - SaveGX * 2) * 1440 / LogX),
          Round((SaveDY - SaveGY * 2) * 1440 / LogY));
        EMF := TMetafile.Create;
        EMF.Width := SaveDX - SaveGX * 2;
        EMF.Height := SaveDY - SaveGY * 2;
        EMFCanvas := TMetafileCanvas.Create(EMF, 0);
        EMFCanvas.Brush.Style := bsClear;
        hdc := EMFCanvas.Handle;
      end
    else
    begin
      LogX := Screen.PixelsPerInch;
      LogY := LogX;
      rc := Rect(0, 0, Round((DX - GapX * 2) * 1440 / LogX),
        Round((DY - GapY * 2) * 1440 / LogY));
    end;
    hdcTarget := hdc;
    rcPage := rc;
    LastChar := CharFrom;
    chrg.cpMin := LastChar;
    chrg.cpMax := -1;
    mm := SetMapMode(hdc, MM_TEXT);
    LastChar := re.Perform(EM_FORMATRANGE, Integer(Render), Integer(@Range));
    SetMapMode(hdc, mm);
  end;
  re.Perform(EM_FORMATRANGE, 0, 0);
  if not Render then
    ReleaseDC(0, Range.hdc)
  else if not IsPrinting then
  begin
    EMFCanvas.Free;
    if DocMode <> dmDesigning then
      Canvas.StretchDraw(DRect, EMF)
    else
    begin
      BMP := TBitmap.Create;
      BMP.Width := DRect.Right - DRect.Left + 1;
      BMP.Height := DRect.Bottom - DRect.Top + 1;
      BMP.Canvas.StretchDraw(Rect(0, 0, BMP.Width, BMP.Height), EMF);
      Canvas.Draw(DRect.Left, DRect.Top, BMP);
      BMP.Free;
    end;
    EMF.Free;
  end;
end;
{$WARNINGS ON}

procedure TfrRxRichView.Draw(Canvas: TCanvas);
begin
  BeginDraw(Canvas);
  CalcGaps;
  with Canvas do
  begin
    ShowBackground;
    CharFrom := 0;
    InflateRect(DRect, -gapx, -gapy);
    if (dx > 0) and (dy > 0) then
      ShowRich(True);
    ShowFrame;
  end;
  RestoreCoord;
end;

procedure TfrRxRichView.StreamOut(Stream: TStream);
var
  SaveTag: String;
  n: Integer;
begin
  BeginDraw(Canvas);
  Memo1.Assign(Memo);
  CurReport.InternalOnEnterRect(Memo1, Self);
  frInterpretator.DoScript(Script);
  if not Visible then Exit;

  SaveTag := Tag;
  if (Tag <> '') and (Pos('[', Tag) <> 0) then
    ExpandVariables(Tag);

  AssignRich(SRichEdit, RichEdit);
  if (Flags and flTextOnly) = 0 then
    GetRichData(SRichEdit);

  if DrawMode = drPart then
  begin
    CharFrom := LastChar;
    ShowRich(False);
    n := SRichEdit.GetTextLen - LastChar + 1;
    if n > 0 then
    begin
      SRichEdit.SelStart := LastChar;
      SRichEdit.SelLength := n;
      SRichEdit.SelText := '';
    end;

    SRichEdit.SelStart := 0;
    SRichEdit.SelLength := CurChar;
    SRichEdit.SelText := '';

    CurChar := LastChar;
  end;

  Stream.Write(Typ, 1);
  frWriteString(Stream, ClassName);
  Flag := True;
  SaveToStream(Stream);
  Flag := False;

  Tag := SaveTag;
end;

function TfrRxRichView.CalcHeight: Integer;
begin
  LastChar := 0;
  CurChar := 0;
  Result := 0;
  frInterpretator.DoScript(Script);
  if not Visible then Exit;

  Memo1.Assign(Memo);
  CurReport.InternalOnEnterRect(Memo1, Self);
  AssignRich(SRichEdit, RichEdit);
  if (Flags and flTextOnly) = 0 then
    GetRichData(SRichEdit);
  CharFrom := 0;
  Result := DoCalcHeight;
end;

function TfrRxRichView.MinHeight: Integer;
begin
  Result := 8;