ariched.pas

来自「delphi编程控件」· PAS 代码 · 共 2,114 行 · 第 1/5 页

    function GetCol: Integer;
    function GetModified: Boolean;
    function GetMultiLevelUndoRedo: Boolean;
    function GetPlainText: Boolean;
    function GetReadOnly: Boolean;
    function GetRedoName: string;
    function GetRow: Integer;
    function GetSelLength: Integer;
    function GetSelStart: Integer;
    function GetSelText: string;
    function GetUndoName: string;
    procedure SetAutoURLDetect(Value: Boolean);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetCol(Value: Integer);
    procedure SetDefAttributes(Value: TAutoTextAttributes);
    procedure SetHideScrollBars(Value: Boolean);
    procedure SetHideSelection(Value: Boolean);
    procedure SetMaxLength(Value: Integer);
    procedure SetModified(Value: Boolean);
    procedure SetMultiLevelUndoRedo(Value: Boolean);
    procedure SetPlainText(Value: Boolean);
    procedure SetReadOnly(value: Boolean);
    procedure SetRichEditStrings(Value: TStrings);
    procedure SetRow(Value: Integer);
    procedure SetScrollBars(Value: TAutoScrollStyle);
    procedure SetSelAttributes(Value: TAutoTextAttributes);
    procedure SetSelectionBar(Value: Boolean);
    procedure SetSelLength(Value: Integer);
    procedure SetSelStart(Value: Integer);
    procedure SetSelText(const Value: string);
    procedure SetUndoRedoLimit(Value: Integer);
    procedure SetWordWrap(Value: Boolean);

    procedure EMSetRect(var Message: TMessage); message EM_SETRECT;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  protected
    procedure Change; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure DoLinkClick(const LinkName: string); virtual;
    procedure KeyPress(var Key: Char); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function ProtectChange(StartPos, EndPos: Integer): Boolean; virtual;
    procedure RequestSize(const Rect: TRect); virtual;
    function SaveClipboard(NumObj, NumChars: Integer): Boolean; virtual;
    procedure SelectionChange; dynamic;

    property OnProtectChange: TAutoRichEditProtectChange
      read FOnProtectChange write FOnProtectChange;
    property OnResizeRequest: TAutoRichEditResizeEvent
      read FOnResizeRequest write FOnResizeRequest;
    property OnSaveClipboard: TAutoRichEditSaveClipboard
      read FOnSaveClipboard write FOnSaveClipboard;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { IUnknown }
    {$IFDEF DELPHI4}
    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
    {$ENDIF}
    procedure Clear; virtual;
    procedure ClearSelection;
    procedure CopyToClipboard;
    procedure CutToClipboard;
    procedure DoVerb(Verb: Smallint);
    function InsertObjectDialog: Boolean;
    procedure FindDialog;
    function FindText(const SearchStr: string;
      StartPos, Length: Integer; Options: TAutoSearchTypes): Integer;
    procedure ParagraphDialog;
    procedure PasteFromClipboard;
    procedure Print(const Caption: string);
    procedure Redo;
    procedure ReplaceDialog;
    procedure SelectAll;
    procedure Undo;

    property AutoURLDetect: Boolean read GetAutoURLDetect
      write SetAutoURLDetect;
    property BorderStyle: TBorderStyle read FBorderStyle
      write SetBorderStyle default bsSingle;
    property CanPaste: Boolean read GetCanPaste;
    property CanRedo: Boolean read GetCanRedo;
    property CanUndo: Boolean read GetCanUndo;
    property Col: Integer read GetCol write SetCol;
    property DefAttributes: TAutoTextAttributes read FDefAttributes
      write SetDefAttributes;
    property HideScrollBars: Boolean read FHideScrollBars
      write SetHideScrollBars default True;
    property HideSelection: Boolean read FHideSelection
      write SetHideSelection default True;
    property Lines: TStrings read FRichEditStrings
      write SetRichEditStrings;
    property MaxLength: Integer read FMaxLength write SetMaxLength default 0;
    property Modified: Boolean read GetModified write SetModified;
    property MultiCharUndoRedo: Boolean read FMultiCharUndoRedo
      write FMultiCharUndoRedo default True;
    property MultiLevelUndoRedo: Boolean read GetMultiLevelUndoRedo
      write SetMultiLevelUndoRedo;
    property PageRect: TRect read FPageRect write FPageRect;
    property Paragraph: TAutoParaAttributes read FParagraph;
    property PlainText: Boolean read GetPlainText write SetPlainText;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly;
    property RedoName: string read GetRedoName;
    property RichEditOle: IRichEditOle read FRichEditOle;
    property Row: Integer read GetRow write SetRow;
    property Ruler: TWinControl read FRuler write FRuler;
    property ScrollBars: TAutoScrollStyle read FScrollBars
      write SetScrollBars default ssVertical;
    property SelAttributes: TAutoTextAttributes read FSelAttributes
      write SetSelAttributes;
    property SelectionBar: Boolean read FSelectionBar
      write SetSelectionBar default False;
    property SelLength: Integer read GetSelLength write SetSelLength;
    property SelStart: Integer read GetSelStart write SetSelStart;
    property SelText: string read GetSelText write SetSelText;
    property UndoName: string read GetUndoName;
    property UndoRedoLimit: Integer read FUndoRedoLimit
      write SetUndoRedoLimit;
    property WantReturns: Boolean read FWantReturns write FWantReturns default True;
    property WantTabs: Boolean read FWantTabs write FWantTabs default True;
    property WordWrap: Boolean read FWordWrap write SetWordWrap default True;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnLinkClick: TAutoRichEditLinkClick read FOnLinkClick
      write FOnLinkClick;
    property OnSelectionChange: TNotifyEvent read FOnSelectionChange
      write FOnSelectionChange;
  end;

  TAutoRichEdit = class(TCustomAutoRichEdit)
  published
    property Align;
    property AutoURLDetect;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property HideScrollBars;
    property HideSelection;
    property ImeMode;
    property ImeName;
    property Lines;
    property MaxLength;
    property MultiCharUndoRedo;
    property MultiLevelUndoRedo;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentShowHint;
    property PlainText;
    property ReadOnly;
    property ScrollBars;
    property SelectionBar;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property UndoRedoLimit;
    property Visible;
    property WantReturns;
    property WantTabs;
    property WordWrap;

    property OnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnLinkClick;
    property OnProtectChange;
    property OnResizeRequest;
    property OnSaveClipboard;
    property OnSelectionChange;
    property OnStartDrag;
  end;

implementation

uses
  ComObj, OleDlg, OleCtnrs, Printers, ShellAPI, AREParag, ARERuler;

const
  sRichEditInsertError = 'RichEdit line insertion error';
  sRichEditLoadFail = 'Failed to Load Stream';
  sRichEditSaveFail = 'Failed to Save Stream';

  sRichEditShowAsIconFail = 'Object couldn''t be displayed as an icon.';
  sRichEditInsertObjectFail = 'Object couldn''t be inserted';
  sRichEditInsertObjectErrorBoxCaption = 'Insert Object';

  sRichEditCutCaption = 'Cu&t';
  sRichEditCopyCaption = '&Copy';
  sRichEditPasteCaption = '&Paste';

  UndoRedonameString: array[0..5] of string =
    ('', 'Typing', 'Clear', 'Move', 'Cut', 'Paste');

  sRichEditFoundResultCaption = 'Information';
  sRichEditTextNotFound = 'The search text is not found.';
  sRichEditReplaceAllResult = 'Replaced %d occurances.';

function HimetricToPixels(const P: TPoint): TPoint;
var
  DC: HDC;
  PixPerInch: TPoint;
begin
  DC := GetDC(0);
  PixPerInch.X := GetDeviceCaps(DC, LOGPIXELSX);
  PixPerInch.Y := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0, DC);
  Result.X := MulDiv(P.X, PixPerInch.X, 2540);
  Result.Y := MulDiv(P.Y, PixPerInch.Y, 2540);
end;

{ TAutoTextAttributes }

constructor TAutoTextAttributes.Create(AOwner: TCustomAutoRichEdit;
  AttributeType: TAttributeType);
begin
  inherited Create;
  RichEdit := AOwner;
  FType := AttributeType;
end;

procedure TAutoTextAttributes.GetAttributes(var Format: TCharFormat2);
begin
  InitFormat(Format);
  if RichEdit.HandleAllocated then
    SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
      WPARAM(FType = atSelected), LPARAM(@Format));
end;

procedure TAutoTextAttributes.InitFormat(var Format: TCharFormat2);
begin
  FillChar(Format, SizeOf(Format), 0);
  Format.cbSize := SizeOf(Format);
end;

procedure TAutoTextAttributes.SetAttributes(var Format: TCharFormat2);
var
  Flag: Longint;
begin
  if FType = atSelected then Flag := SCF_SELECTION
  else Flag := 0;
  if RichEdit.HandleAllocated then
    SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, Flag, LPARAM(@Format));
end;

function TAutoTextAttributes.GetBackColor: TColor;
var
  Format: TCharFormat2;
begin
  GetAttributes(Format);
  with Format do
    if dwEffects and CFE_AUTOBACKCOLOR <> 0 then
      Result := clWindow
    else Result := crBackColor;
end;

procedure TAutoTextAttributes.SetBackColor(Value: TColor);
var
  Format: TCharFormat2;
begin
  InitFormat(Format);
  with Format do
  begin
    dwMask := CFM_BACKCOLOR;
    if Value = clWindow then
      dwEffects := CFE_AUTOBACKCOLOR
    else crBackColor := ColorToRGB(Value);
  end;
  SetAttributes(Format);
end;

function TAutoTextAttributes.GetCharset: TFontCharset;
var
  Format: TCharFormat2;
begin
  GetAttributes(Format);
  Result := Format.bCharset;
end;

procedure TAutoTextAttributes.SetCharset(Value: TFontCharset);
var
  Format: TCharFormat2;
begin
  InitFormat(Format);
  with Format do
  begin
    dwMask := CFM_CHARSET;
    bCharSet := Value;
  end;
  SetAttributes(Format);
end;

function TAutoTextAttributes.GetColor: TColor;
var
  Format: TCharFormat2;
begin
  GetAttributes(Format);
  with Format do
    if dwEffects and CFE_AUTOCOLOR <> 0 then
      Result := clWindowText
    else Result := crTextColor;
end;

procedure TAutoTextAttributes.SetColor(Value: TColor);
var
  Format: TCharFormat2;
begin
  InitFormat(Format);
  with Format do
  begin
    dwMask := CFM_COLOR;
    if Value = clWindowText then
      dwEffects := CFE_AUTOCOLOR
    else crTextColor := ColorToRGB(Value);
  end;
  SetAttributes(Format);
end;

function TAutoTextAttributes.GetConsistentAttributes: TConsistentAttributes;
var
  Format: TCharFormat2;
begin
  Result := [];
  if RichEdit.HandleAllocated and (FType = atSelected) then
  begin
    InitFormat(Format);
    SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
      WPARAM(FType = atSelected), LPARAM(@Format));
    with Format do
    begin
      if dwMask and CFM_BOLD <> 0 then Include(Result, caBold);
      if dwMask and CFM_COLOR <> 0 then Include(Result, caColor);
      if dwMask and CFM_FACE <> 0 then Include(Result, caFace);
      if dwMask and CFM_ITALIC <> 0 then Include(Result, caItalic);
      if dwMask and CFM_SIZE <> 0 then Include(Result, caSize);
      if dwMask and CFM_STRIKEOUT <> 0 then Include(Result, caStrikeOut);
      if dwMask and CFM_UNDERLINE <> 0 then Include(Result, caUnderline);
      if dwMask and CFM_PROTECTED <> 0 then Include(Result, caProtected);
      if dwMask and CFM_LINK <> 0 then Include(Result, caLinked);
      { new in RichEdit 2.0 }
      if dwMask and CFM_BACKCOLOR <> 0 then Include(Result, caBackColor);
      if dwMask and CFM_DISABLED <> 0 then Include(Result, caDisabled);
      if dwMask and CFM_WEIGHT <> 0 then Include(Result, caWeight);
      if dwMask and CFM_SUBSCRIPT <> 0 then Include(Result, caScript);
      if dwMask and CFM_REVAUTHOR <> 0 then Include(Result, caRevAuthor);
    end;
  end;
end;

function TAutoTextAttributes.GetDisabled: Boolean;
var
  Format: TCharFormat2;
begin
  GetAttributes(Format);
  Result := Format.dwEffects and CFE_DISABLED <> 0;
end;

procedure TAutoTextAttributes.SetDisabled(Value: Boolean);
var
  Format: TCharFormat2;
begin
  InitFormat(Format);
  with Format do
  begin
    dwMask := CFM_DISABLED;
    if Value then dwEffects := CFE_DISABLED;
  end;
  SetAttributes(Format);
end;

function TAutoTextAttributes.GetHeight: Integer;
begin
  Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
end;

procedure TAutoTextAttributes.SetHeight(Value: Integer);
begin
  Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
end;

function TAutoTextAttributes.GetLinked: Boolean;
var
  Format: TCharFormat2;
begin
  GetAttributes(Format);
  Result := Format.dwEffects and CFE_LINK <> 0;
end;

procedure TAutoTextAttributes.SetLinked(Value: Boolean);
var
  Format: TCharFormat2;
begin
  InitFormat(Format);
  with Format do
  begin
    dwMask := CFM_LINK;
    if Value then dwEffects := CFE_LINK;
  end;
  SetAttributes(Format);
end;