rm_richedit.pas

胜天进销存源码,国产优秀的进销存

{*****************************************}
{                                         }
{         Report Machine v2.0             }
{           Rich Add-In Object            }
{                                         }
{*****************************************}

unit RM_RichEdit;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Menus,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, ClipBrd,
  DB, RM_Class, RM_Ctrls, RM_DsgCtrls, RichEdit, ToolWin
{$IFDEF USE_INTERNAL_JVCL}, rm_JvInterpreter{$ELSE}, JvInterpreter{$ENDIF}
{$IFDEF TntUnicode}, TntComCtrls, TntSysUtils{$ENDIF}
{$IFDEF Delphi4}, ImgList{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

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

  TRMRichEditVersion = 1..3;
  TRMSubscriptStyle = (rmssNone, rmssSubscript, rmssSuperscript);

{$IFNDEF Delphi3}
  TCharFormat2A = record
    cbSize: UINT;
    dwMask: DWORD;
    dwEffects: DWORD;
    yHeight: Longint;
    yOffset: Longint;
    crTextColor: TColorRef;
    bCharSet: Byte;
    bPitchAndFamily: Byte;
    szFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;
    { new fields in version 2.0 }
    wWeight: Word; { Font weight (LOGFONT value)             }
    sSpacing: Smallint; { Amount to space between letters         }
    crBackColor: TColorRef; { Background color                        }
    lid: LCID; { Locale ID                               }
    dwReserved: DWORD; { Reserved. Must be 0                     }
    sStyle: Smallint; { Style handle                            }
    wKerning: Word; { Twip size above which to kern char pair }
    bUnderlineType: Byte; { Underline type                          }
    bAnimation: Byte; { Animated text like marching ants        }
    bRevAuthor: Byte; { Revision author index                   }
    bReserved1: Byte;
  end;
  TCharFormat2 = TCharFormat2A;
{$ENDIF}

  TRMRichEdit = {$IFDEF TntUnicode}TTntRichEdit{$ELSE}TRichEdit{$ENDIF};

  { TRMRichView }
  TRMRichView = class(TRMStretcheableView)
  private
    FStartCharPos, FEndCharPos, FSaveCharPos: Integer;
    FRichEdit, FSRichEdit: TRMRichEdit;
    FPixelsPerInch: TPoint;
    FUseSRichEdit: Boolean;

    function SRichEdit: TRMRichEdit;
    procedure GetRichData(aSource: TRMRichEdit);
    function FormatRange(aDC: HDC; aFormatDC: HDC; const aRect: TRect; aCharRange: TCharRange;
      aRender: Boolean): Integer;
    function DoCalcHeight: Integer;
    procedure ShowRichText(aRender: Boolean);
  protected
    procedure Prepare; override;
    procedure GetMemoVariables; override;
    function GetViewCommon: string; override;
    procedure ClearContents; override;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Draw(aCanvas: TCanvas); override;
    procedure PlaceOnEndPage(aStream: TStream); override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;

    procedure GetBlob; override;
    procedure LoadFromRichEdit(aRichEdit: TRMRichEdit);
    function CalcHeight: Integer; override;
    function RemainHeight: Integer; override;
    procedure DefinePopupMenu(aPopup: TRMCustomMenuItem); override;
    procedure ShowEditor; override;
  published
    property RichEdit: TRMRichEdit read FRichEdit;
    property GapLeft;
    property GapTop;
    property ShiftWith;
    property TextOnly;
    property BandAlign;
    property LeftFrame;
    property RightFrame;
    property TopFrame;
    property BottomFrame;
    property FillColor;
    property PrintFrame;
    property Printable;
  end;

  { TRMRichForm }
  TRMRichForm = class(TForm)
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    FontDialog1: TFontDialog;
    ToolBar: TToolBar;
    btnFileOpen: TToolButton;
    btnFileSave: TToolButton;
    btnFilePrint: TToolButton;
    ToolButton5: TToolButton;
    btnUndo: TToolButton;
    btnCut: TToolButton;
    btnCopy: TToolButton;
    btnPaste: TToolButton;
    ToolButton10: TToolButton;
    ToolbarImages: TImageList;
    btnInsertField: TToolButton;
    btnCancel: TToolButton;
    btnOK: TToolButton;
    StatusBar: TStatusBar;
    PrintDialog: TPrintDialog;
    btnFont: TToolButton;
    ToolButton2: TToolButton;
    ToolBar1: TToolBar;
    ToolButton4: TToolButton;
    ToolButton8: TToolButton;
    btnAlignLeft: TToolButton;
    btnAlignCenter: TToolButton;
    btnAlignRight: TToolButton;
    ToolButton13: TToolButton;
    btnBullets: TToolButton;
    ToolButton6: TToolButton;
    ToolButton3: TToolButton;
    ToolButton7: TToolButton;
    MainMenu: TMainMenu;
    FileMenu: TMenuItem;
    FileNewItem: TMenuItem;
    FileOpenItem: TMenuItem;
    FileSaveAsItem: TMenuItem;
    N1: TMenuItem;
    FileExitItem: TMenuItem;
    EditMenu: TMenuItem;
    EditUndoItem: TMenuItem;
    N2: TMenuItem;
    EditCutItem: TMenuItem;
    EditCopyItem: TMenuItem;
    EditPasteItem: TMenuItem;
    N5: TMenuItem;
    EditFontItem: TMenuItem;
    N3: TMenuItem;
    EditInsertFieldItem: TMenuItem;
    btnFontBold: TToolButton;
    btnFontItalic: TToolButton;
    btnFontUnderline: TToolButton;
    ToolButton1: TToolButton;
    btnSuperscript: TToolButton;
    btnSubscript: TToolButton;

    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 FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure btnInsertFieldClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure btnCutClick(Sender: TObject);
    procedure btnCopyClick(Sender: TObject);
    procedure btnPasteClick(Sender: TObject);
    procedure FileNewItemClick(Sender: TObject);
    procedure btnFilePrintClick(Sender: TObject);
    procedure EditorChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnFontClick(Sender: TObject);
    procedure btnBulletsClick(Sender: TObject);
    procedure btnAlignLeftClick(Sender: TObject);
    procedure btnFontBoldClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnSuperscriptClick(Sender: TObject);
  private
    FStatusString: string;
    FUpdating: Boolean;
    FFileName: string;
    FcmbFont: TRMFontComboBox;
    FcmbFontSize: TComboBox;
    FRuler: TRMRuler;
    FBtnFontColor: TRMColorPickerButton;

    function CurrText: TTextAttributes;
    procedure SetFileName(const FileName: string);
    procedure SetModified(Value: Boolean);
    procedure SetEditRect;
    procedure UpdateCaretPos;
    procedure OnCmbFontChange(Sender: TObject);
    procedure OnCmbFontSizeChange(Sender: TObject);
    procedure OnColorChangeEvent(Sender: TObject);
    procedure Localize;
  public
    Editor: TRMRichEdit;
  end;

procedure RMInitFormat(var Format: TCharFormat2);
function RMGetSubscriptStyle(ARichEdit: TCustomRichEdit): TRMSubscriptStyle;
procedure RMSetSubscriptStyle(ARichEdit: TCustomRichEdit; AStyle: TRMSubscriptStyle);
procedure RMAssignRich(Rich1, Rich2: TRMRichEdit);

var
  RichEditVersion: TRMRichEditVersion;

implementation

uses RM_Parser, RM_Utils, RM_Const, RM_Const1, RM_Printer, RM_Common;

const
  RulerAdj = 4 / 3;
  GutterWid = 6;

{$R *.DFM}

procedure RMInitFormat(var Format: TCharFormat2);
begin
  FillChar(Format, SizeOf(Format), 0);
  if RichEditVersion >= 2 then
    Format.cbSize := SizeOf(Format)
  else
    Format.cbSize := SizeOf(TCharFormat);
end;

function RMGetSubscriptStyle(ARichEdit: TCustomRichEdit): TRMSubscriptStyle;
var
  Format: TCharFormat2;

  procedure _GetAttributes;
  begin
    RMInitFormat(Format);
    if ARichEdit.HandleAllocated then
      SendMessage(ARichEdit.Handle, EM_GETCHARFORMAT, SCF_SELECTION, LPARAM(@Format));
  end;

begin
  Result := rmssNone;
  if RichEditVersion < 2 then
    Exit;
  _GetAttributes;
  with Format do
  begin
    if (dwEffects and CFE_SUBSCRIPT) <> 0 then
      Result := rmssSubscript
    else if (dwEffects and CFE_SUPERSCRIPT) <> 0 then
      Result := rmssSuperscript;
  end;
end;

procedure RMSetSubscriptStyle(ARichEdit: TCustomRichEdit; AStyle: TRMSubscriptStyle);
var
  Format: TCharFormat2;
begin
  if RichEditVersion < 2 then
    Exit;
  RMInitFormat(Format);
  with Format do
  begin
    dwMask := DWORD(CFM_SUBSCRIPT);
    case AStyle of
      rmssSubscript: dwEffects := CFE_SUBSCRIPT;
      rmssSuperscript: dwEffects := CFE_SUPERSCRIPT;
    end;
  end;

  if ARichEdit.HandleAllocated then
    SendMessage(ARichEdit.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@Format));
end;

procedure RMAssignRich(Rich1, Rich2: TRMRichEdit);
var
  st: TMemoryStream;
begin
  st := TMemoryStream.Create;
  try
    with Rich2 do
    begin
      SelStart := 0;
      SelLength := Length(Text);
      SelAttributes.Protected := FALSE;
      Lines.SaveToStream(st);
    end;
    st.Position := 0;
    Rich1.Lines.LoadFromStream(st);
  finally
    st.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRichView}

constructor TRMRichView.Create;
begin
  inherited Create;
  BaseName := 'Rich';

  FRichEdit := TRMRichEdit.Create(RMDialogForm);
  with FRichEdit do
  begin
    Parent := RMDialogForm;
    Visible := False;
    Font.Charset := StrToInt(RMLoadStr(SCharset));
    Font.Name := RMLoadStr(SRMDefaultFontName);
    Font.Size := 11;
  end;
  FSRichEdit := nil;
  FUseSRichEdit := False;
end;

destructor TRMRichView.Destroy;
begin
  if RMDialogForm <> nil then
  begin
    FRichEdit.Free;
    FRichEdit := nil;
    FSRichEdit.Free;
    FSRichEdit := nil;
  end;

  inherited Destroy;
end;

function TRMRichView.SRichEdit: TRMRichEdit;
begin
  if FSRichEdit = nil then
  begin
    FSRichEdit := TRMRichEdit.Create(RMDialogForm);
    with FSRichEdit do
    begin
      Parent := RMDialogForm;
      Visible := False;
    end;
  end;
  Result := FSRichEdit;
end;

procedure TRMRichView.GetRichData(aSource: TRMRichEdit);
{$IFDEF TntUnicode}
var
  lParName, S: string;
  i, j: Integer;

  function _GetBrackedVariable(const s: WideString; var i, j: Integer): string;
  var
    c: Integer;
    fl1, fl2: Boolean;
  begin
    j := i; fl1 := True; fl2 := True; c := 0;
    Result := '';
    if (s = '') or (j > Length(s)) then
      Exit;

    Dec(j);
    repeat
      Inc(j);
      if fl1 and fl2 then
      begin
        if s[j] = '[' then
        begin
          if c = 0 then
            i := j;
          Inc(c);
        end
        else if s[j] = ']' then
          Dec(c);
      end;

      if fl1 then
      begin
        if s[j] = '"' then
          fl2 := not fl2;
      end;

      if fl2 then
      begin
        if s[j] = '''' then
          fl1 := not fl1;
      end;
    until (c = 0) or (j >= Length(s));

    Result := Copy(s, i + 1, j - i - 1);
  end;

begin
  if ParentReport.Flag_TableEmpty then
  begin
    aSource.Lines.Text := '';
    Exit;
  end;

  with aSource do
  begin
    try
      Lines.BeginUpdate;
      i := FindText('[', 0, Length(Text), []) + 1;
      while i > 0 do
      begin
        SelStart := i - 1;
        if Win32PlatformIsUnicode then
          lParName := _GetBrackedVariable(Text, i, j)
        else
          lParName := RMGetBrackedVariable(Text, i, j);

        InternalOnGetValue(Self, lParName, S, True);
        SelLength := j - i + 1;
        SelText := UTF8Decode(S);
        Inc(i, Length(S) - 1);
        i := FindText('[', i, Length(Text) - i, []) + 1;
      end;
    finally
      Lines.EndUpdate;
    end;
  end;
end;
{$ELSE}
var
  lParName, S: string;
  i, j: Integer;
begin
  if ParentReport.Flag_TableEmpty then
  begin
    aSource.Lines.Text := '';
    Exit;
  end;

  with aSource do
  begin
    try
      Lines.BeginUpdate;
      i := FindText('[', 0, Length(Text), []) + 1;
      while i > 0 do
      begin
        SelStart := i - 1;
        lParName := RMGetBrackedVariable(Text, i, j);
        InternalOnGetValue(Self, lParName, S, False);
        SelLength := j - i + 1;
        SelText := S;
        Inc(i, Length(S) - 1);
        i := FindText('[', i, Length(Text) - i, []) + 1;
      end;
    finally
      Lines.EndUpdate;
    end;
  end;
end;
{$ENDIF}

function TRMRichView.DoCalcHeight: Integer;
var
  liFormatRange: TFormatRange;
  liLastChar, liMaxLen: Integer;