rm_rich.pas

中小企业管理系统------ ERP系统原代码

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

unit RM_rich;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Menus,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, ClipBrd,
  DB, RM_DBRel, RM_Class, RM_DsgCtrls, RichEdit, ToolWin
{$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}

  { TRMRichView }
  TRMRichView = class(TRMStretcheable)
  private
    FCurChar, FLastChar, FCharFrom: Integer;
    FFlag: Boolean;
    procedure GetRichData(ASource: TRichEdit);
    function DoCalcHeight: Integer;
    procedure ShowRich(Render: Boolean);
    procedure P1Click(Sender: TObject);
    procedure RichEditor(Sender: TObject);
  protected
    function GetViewCommon: string; override;
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
  public
    RichEdit: TRichEdit;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(aCanvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure GetBlob(b: TField); override;
    procedure LoadFromRichEdit(aRichEdit: TRichEdit);
    function CalcHeight: Integer; override;
    function MinHeight: Integer; override;
    function LostSpace: Integer; override;
    function RemainHeight: Integer; override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  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;
    Editor: TRichEdit;
    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
  end;

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

var
  RichEditVersion: TRMRichEditVersion;

implementation

uses RM_Pars, RM_Intrp, RM_Utils, RM_Const, RM_Const1, RM_Prntr, RM_CmpReg;

const
  RulerAdj = 4 / 3;
  GutterWid = 6;

{$R *.DFM}

var
  FRichEdit: TRichEdit; // temporary rich used during TRichView drawing

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;

function SRichEdit: TRichEdit;
begin
  if FRichEdit = nil then
  begin
    FRichEdit := TRichEdit.Create(RMDialogForm);
    with FRichEdit do
    begin
      Parent := RMDialogForm;
    end;
  end;
  Result := FRichEdit;
end;

procedure RMAssignRich(Rich1, Rich2: TRichEdit);
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;
  RichEdit := TRichEdit.Create(RMDialogForm);
  RichEdit.Parent := RMDialogForm;
  RichEdit.Visible := False;
  RichEdit.Font.Charset := StrToInt(RMLoadStr(SCharset));
  RichEdit.Font.Name := RMLoadStr(SRMDefaultFontName);
  RichEdit.Font.Size := 11;
  BaseName := 'Rich';
end;

destructor TRMRichView.Destroy;
begin
  if RMDialogForm <> nil then
    RichEdit.Free;
  inherited Destroy;
end;

procedure TRMRichView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('GapX', [RMdtInteger], nil);
  AddProperty('GapY', [RMdtInteger], nil);
  AddProperty('Lines', [RMdtHasEditor, RMdtOneObject], RichEditor);
  AddProperty('Stretched', [RMdtBoolean], nil);
  AddProperty('TextOnly', [RMdtBoolean], nil);
  AddProperty('DataField', [RMdtOneObject, RMdtHasEditor, RMdtString], RMFieldEditor);

  AddProperty('OnBeforePrint', [RMdtHasEditor, RMdtOneObject], RMScript_BeforePrintEditor);
  AddProperty('OnAfterPrint', [RMdtHasEditor, RMdtOneObject], RMScript_AfterPrintEditor);
end;

procedure TRMRichView.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 TRMRichView.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;

procedure TRMRichView.GetRichData(ASource: TRichEdit);
var
  R, S: string;
  i, j: Integer;
begin
  if 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;
        R := RMGetBrackedVariable(Text, i, j);
        CurReport.InternalOnGetValue(R, S);
        SelLength := j - i + 1;
        SelText := S;
        Inc(i, Length(S));
        i := FindText('[', i, Length(Text) - i, []) + 1;
      end;
    finally
      Lines.EndUpdate;
    end;
  end;
end;

function TRMRichView.DoCalcHeight: Integer;
var
  Range: TFormatRange;
  LastChar, MaxLen, LogX, LogY, NewDY, LowDy, HighDy: Integer;
  StopRender, Fit: Boolean;
begin
  FillChar(Range, SizeOf(TFormatRange), 0);
  with Range do
  begin
    hdc := GetDC(0);
    hdcTarget := hdc;
    LogX := Screen.PixelsPerInch;
    LogY := LogX;

    LowDy := 0;
    HighDY := 1000000;
    while HighDy - LowDy > 1 do
    begin
      NewDY := LowDy + (HighDy - LowDy) div 2;
      rc := Rect(0, 0, Round((DX - GapX * 2 - _CalcHFrameWidth(LeftFrame.Width, RightFrame.Width)) * 1440 / LogX), Round(NewDY * 1440.0 / LogY));
      rcPage := rc;
      LastChar := FCharFrom;
      MaxLen := SRichEdit.GetTextLen;
      chrg.cpMax := -1;
      repeat