ariched.pas

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

unit ARichEd;

interface
{$I aclver.inc}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ActiveX, RichEdit;

const
// Flags to specify which interfaces should be returned in the structure above
  REO_GETOBJ_NO_INTERFACES  = $00000000;
  REO_GETOBJ_POLEOBJ	    = $00000001;
  REO_GETOBJ_PSTG	    = $00000002;
  REO_GETOBJ_POLESITE	    = $00000004;
  REO_GETOBJ_ALL_INTERFACES = $00000007;

// Place object at selection
  REO_CP_SELECTION = ULONG(-1);

// Use character position to specify object instead of index
  REO_IOB_SELECTION = ULONG(-1);
  REO_IOB_USE_CP    = ULONG(-2);

// Object flags
  REO_NULL	      =	$00000000;  // No flags
  REO_READWRITEMASK   =	$0000003F;  // Mask out RO bits
  REO_DONTNEEDPALETTE =	$00000020;  // Object doesn't need palette
  REO_BLANK	      =	$00000010;  // Object is blank
  REO_DYNAMICSIZE     =	$00000008;  // Object defines size always
  REO_INVERTEDSELECT  =	$00000004;  // Object drawn all inverted if sel
  REO_BELOWBASELINE   =	$00000002;  // Object sits below the baseline
  REO_RESIZABLE	      =	$00000001;  // Object may be resized
  REO_LINK	      =	$80000000;  // Object is a link (RO)
  REO_STATIC	      =	$40000000;  // Object is static (RO)
  REO_SELECTED	      =	$08000000;  // Object selected (RO)
  REO_OPEN	      =	$04000000;  // Object open in its server (RO)
  REO_INPLACEACTIVE   =	$02000000;  // Object in place active (RO)
  REO_HILITED	      =	$01000000;  // Object is to be hilited (RO)
  REO_LINKAVAILABLE   =	$00800000;  // Link believed available (RO)
  REO_GETMETAFILE     =	$00400000;  // Object requires metafile (RO)

// flags for IRichEditOle.GetClipboardData,
// IRichEditOleCallback.GetClipboardData and
// IRichEditOleCallback.QueryAcceptData
  RECO_PASTE = $00000000;  // paste from clipboard
  RECO_DROP  = $00000001;  // drop
  RECO_COPY  = $00000002;  // copy to the clipboard
  RECO_CUT   = $00000003;  // cut to the clipboard
  RECO_DRAG  = $00000004;  // drag

// Undocumented flag for EM_FINDTEXT(EX) in RichEdit 2.0
  FT_FORWARD = 1;  // search forward (default - backward)

// RichEdit interface GUIDs
  IID_IRichEditOle: TGUID = (
    D1:$00020D00;D2:0;D3:0;D4:($C0,0,0,0,0,0,0,$46));
  IID_IRichEditOleCallback: TGUID = (
    D1:$00020D03;D2:0;D3:0;D4:($C0,0,0,0,0,0,0,$46));

type
// Structure passed to GetObject and InsertObject
  TReObject = record
    cbStruct: DWORD;	    	// Size of structure
    cp: ULONG;			// Character position of object
    clsid: TCLSID;		// Class ID of object
    oleobj: IOleObject;	        // OLE object interface
    stg: IStorage;		// Associated storage interface
    olesite: IOleClientSite;	// Associated client site interface
    size: TSize;		// Size of object (may be 0,0)
    dvaspect: DWORD;		// Display aspect to use
    dwFlags: DWORD;		// Object status flags
    dwUser: DWORD;		// Dword for user's use
  end;

  REFCLSID = TIID;

{
  IRichEditOle

  Purpose:
    Interface used by the client of RichEdit to perform OLE-related
    operations.

  REVIEW:
    The methods herein may just want to be regular Windows messages.
}

  IRichEditOle = interface(IUnknown)
    ['{00020D00-0000-0000-C000-000000000046}']
    function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall;
    function GetObjectCount: HResult; stdcall;
    function _GetLinkCount: HResult; stdcall;
    function GetObject(iob: Longint; out reobject: TReObject;
      dwFlags: DWORD): HResult; stdcall;
    function InsertObject(var reobject: TReObject): HResult; stdcall;
    function _ConvertObject(iob: Longint; rclsidNew: REFCLSID;
      lpstrUserTypeNew: LPCSTR): HResult; stdcall;
    function _ActivateAs(rclsid: REFCLSID; rclsidAs: REFCLSID): HResult; stdcall;
    function _SetHostNames(lpstrContainerApp: LPCSTR;
      lpstrContainerObj: LPCSTR): HResult; stdcall;
    function _SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall;
    function _SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall;
    function _HandsOffStorage(iob: Longint): HResult; stdcall;
    function _SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall;
    function _InPlaceDeactivate: HResult; stdcall;
    function _ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    function GetClipboardData(var chrg: TCharRange; reco: DWORD;
      out dataobj: IDataObject): HResult; stdcall;
    function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
      hMetaPict: HGLOBAL): HResult; stdcall;
  end;

{
  IRichEditOleCallback

  Purpose:
    Interface used by the RichEdit to get OLE-related stuff from the
    application using RichEdit.
}

  IRichEditOleCallback = interface(IUnknown)
    ['{00020D03-0000-0000-C000-000000000046}']
    function GetNewStorage(out stg: IStorage): HResult; stdcall;
    function GetInPlaceContext(out Frame: IOleInPlaceFrame;
      out Doc: IOleInPlaceUIWindow;
      lpFrameInfo: POleInPlaceFrameInfo): HResult; stdcall;
    function ShowContainerUI(fShow: BOOL): HResult; stdcall;
    function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
      cp: Longint): HResult; stdcall;
    function DeleteObject(const oleobj: IOleObject): HResult; stdcall;
    function QueryAcceptData(const dataobj: IDataObject;
      var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
      hMetaPict: HGLOBAL): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    function GetClipboardData(const chrg: TCharRange; reco: DWORD;
      out dataobj: IDataObject): HResult; stdcall;
    function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
      var dwEffect: DWORD): HResult; stdcall;
    function GetContextMenu(seltype: Word; const oleobj: IOleObject;
      const chrg: TCharRange; out menu: HMENU): HResult; stdcall;
  end;

  TCustomAutoRichEdit = class;

{ TAutoTextAttributes }

  TAttributeType = (atSelected, atDefaultText);
  TConsistentAttribute = (caBold, caColor, caFace, caItalic,
    caSize, caStrikeOut, caUnderline, caProtected, caLinked,
    caBackColor, caDisabled, caWeight, caScript, caRevAuthor);
  TConsistentAttributes = set of TConsistentAttribute;
  TScript = (rscNone, rscSubScript, rscSuperScript);

  TAutoTextAttributes = class(TPersistent)
  private
    RichEdit: TCustomAutoRichEdit;
    FType: TAttributeType;

    procedure GetAttributes(var Format: TCharFormat2);
    procedure InitFormat(var Format: TCharFormat2);
    procedure SetAttributes(var Format: TCharFormat2);

    function GetBackColor: TColor;
    function GetCharset: TFontCharset;
    function GetColor: TColor;
    function GetConsistentAttributes: TConsistentAttributes;
    function GetDisabled: Boolean;
    function GetHeight: Integer;
    function GetLinked: Boolean;
    function GetName: TFontName;
    function GetOffset: Longint;
    function GetPitch: TFontPitch;
    function GetProtected: Boolean;
    function GetRevAuthor: Byte;
    function GetScript: TScript;
    function GetSize: Integer;
    function GetStyle: TFontStyles;
    function GetWeight: Word;
    procedure SetBackColor(Value: TColor);
    procedure SetCharset(Value: TFontCharset);
    procedure SetColor(Value: TColor);
    procedure SetDisabled(Value: Boolean);
    procedure SetHeight(Value: Integer);
    procedure SetLinked(Value: Boolean);
    procedure SetName(Value: TFontName);
    procedure SetOffset(Value: Longint);
    procedure SetPitch(Value: TFontPitch);
    procedure SetProtected(Value: Boolean);
    procedure SetRevAuthor(Value: Byte);
    procedure SetScript(Value: TScript);
    procedure SetSize(Value: Integer);
    procedure SetStyle(Value: TFontStyles);
    procedure SetWeight(Value: Word);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AOwner: TCustomAutoRichEdit; AttributeType: TAttributeType);
    procedure Assign(Source: TPersistent); override;

    property BackColor: TColor read GetBackColor write SetBackColor;
    property Charset: TFontCharset read GetCharset write SetCharset;
    property Color: TColor read GetColor write SetColor;
    property ConsistentAttributes: TConsistentAttributes
      read GetConsistentAttributes;
    property Disabled: Boolean read GetDisabled write SetDisabled;
    property Height: Integer read GetHeight write SetHeight;
    property Linked: Boolean read GetLinked write SetLinked;
    property Name: TFontName read GetName write SetName;
    property Offset: Longint read GetOffset write SetOffset;
    property Pitch: TFontPitch read GetPitch write SetPitch;
    property Protected: Boolean read GetProtected write SetProtected;
    property RevAuthor: Byte read GetRevAuthor write SetRevAuthor;
    property Script: TScript read GetScript write SetScript;
    property Size: Integer read GetSize write SetSize;
    property Style: TFontStyles read GetStyle write SetStyle;
    property Weight: Word read GetWeight write SetWeight;
  end;

{ TAutoParaAttributes }

  TParagraphAlignment = (paLeft, paRight, paCenter, paJustify);
  TLineSpacingRule = (lsrSingle, lsrOneAndHalf, lsrDouble,
    lsrAtLeast, lsrExactly, lsrMultiple);
  TNumberingStyle = (nsNone, nsBullet);

  TAutoParaAttributes = class(TPersistent)
  private
    RichEdit: TCustomAutoRichEdit;

    procedure GetAttributes(var Paragraph: TParaFormat2);
    procedure InitParagraph(var Paragraph: TParaFormat2);
    procedure SetAttributes(var Paragraph: TParaFormat2);

    function GetAlignment: TParagraphAlignment;
    function GetFirstIndent: Longint;
    function GetFirstIndentInTwips: Longint;
    function GetLeftIndent: Longint;
    function GetLeftIndentInTwips: Longint;
    function GetLineSpacing: Longint;
    function GetLineSpacingInTwips: Longint;
    function GetLineSpacingRule: TLineSpacingRule;
    function GetNumbering: TNumberingStyle;
    function GetRightIndent: Longint;
    function GetRightIndentInTwips: Longint;
    function GetSpaceAfter: Longint;
    function GetSpaceAfterInTwips: Longint;
    function GetSpaceBefore: Longint;
    function GetSpaceBeforeInTwips: Longint;
    function GetTab(Index: Byte): Longint;
    function GetTabCount: Integer;
    procedure SetAlignment(Value: TParagraphAlignment);
    procedure SetFirstIndent(Value: Longint);
    procedure SetFirstIndentInTwips(Value: Longint);
    procedure SetLeftIndent(Value: Longint);
    procedure SetLeftIndentInTwips(Value: Longint);
    procedure SetLineSpacing(Value: Longint);
    procedure SetLineSpacingInTwips(Value: Longint);
    procedure SetLineSpacingRule(Value: TLineSpacingRule);
    procedure SetNumbering(Value: TNumberingStyle);
    procedure SetRightIndent(Value: Longint);
    procedure SetRightIndentInTwips(Value: Longint);
    procedure SetSpaceAfter(Value: Longint);
    procedure SetSpaceAfterInTwips(Value: Longint);
    procedure SetSpaceBefore(Value: Longint);
    procedure SetSpaceBeforeInTwips(Value: Longint);
    procedure SetTab(Index: Byte; Value: Longint);
    procedure SetTabCount(Value: Integer);
  public
    constructor Create(AOwner: TCustomAutoRichEdit);
    procedure Assign(Source: TPersistent); override;
    
    property Alignment: TParagraphAlignment read GetAlignment
      write SetAlignment;
    property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
    property FirstIndentInTwips: Longint read GetFirstIndentInTwips
      write SetFirstIndentInTwips;
    property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
    property LeftIndentInTwips: Longint read GetLeftIndentInTwips
      write SetLeftIndentInTwips;
    property LineSpacing: Longint read GetLineSpacing write SetLineSpacing;
    property LineSpacingInTwips: Longint read GetLineSpacingInTwips
      write SetLineSpacingInTwips;
    property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule
      write SetLineSpacingRule;
    property Numbering: TNumberingStyle read GetNumbering write SetNumbering;
    property RightIndent: Longint read GetRightIndent write SetRightIndent;
    property RightIndentInTwips: Longint read GetRightIndentInTwips
      write SetRightIndentInTwips;
    property SpaceAfter: Longint read GetSpaceAfter write SetSpaceAfter;
    property SpaceAfterInTwips: Longint read GetSpaceAfterInTwips
      write SetSpaceAfterInTwips;
    property SpaceBefore: Longint read GetSpaceBefore write SetSpaceBefore;
    property SpaceBeforeInTwips: Longint read GetSpaceBeforeInTwips
      write SetSpaceBeforeInTwips;
    property Tab[Index: Byte]: Longint read GetTab write SetTab;
    property TabCount: Integer read GetTabCount write SetTabCount;
  end;

{
  TCustomAutoRichEdit

  Purpose:
    RichEdit 2.0 control's class that implements IUnknown,
    IRichEditOleCallback, IOleWindow, IOleInPlaceUIWindow and
    IOleInPlaceFrame interfaces for OLE 2.0 futures.
}

  TAutoRichEditLinkClick = procedure(Sender: TObject;
    const LinkName: string) of object;
  TAutoRichEditProtectChange = procedure(Sender: TObject;
    StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
  TAutoRichEditResizeEvent = procedure(Sender: TObject; Rect: TRect) of object;
  TAutoRichEditSaveClipboard = procedure(Sender: TObject;
    NumObjects, NumChars: Integer; var SaveClipboard: Boolean) of object;
  TAutoSearchType = (stWholeWord, stMatchCase, stForward);
  TAutoSearchTypes = set of TAutoSearchType;
  TAutoScrollStyle = (ssNone, ssHorizontal, ssVertical, ssBoth);

  TCustomAutoRichEdit = class(TWinControl, IUnknown,
    IRichEditOleCallback, IOleWindow, IOleInPlaceUIWindow,
    IOleInPlaceFrame)
  private
    FHiddenControls: TList;
    FRefCount: Longint;
    g_ActiveObject: IOleInPlaceActiveObject;
    OldBoundsRect: TRect;
    PrevMainFormClose, PrevParentFormClose: TCloseEvent;

    FBorderStyle: TBorderStyle;
    FHideScrollBars: Boolean;
    FHideSelection: Boolean;
    FMaxLength: Integer;
    FMultiCharUndoRedo: Boolean;
    FPageRect: TRect;
    FRichEditOle: IRichEditOle;
    FRichEditStrings: TStrings;
    FRuler: TWinControl;
    FScreenLogPixels: Integer;
    FScrollBars: TAutoScrollStyle;
    FSelectionBar: Boolean;
    FDefAttributes: TAutoTextAttributes;  // must be after FRichEditStrings
    FSelAttributes: TAutoTextAttributes;  //            - || -
    FParagraph: TAutoParaAttributes;      //            - || -
    FUndoRedoLimit: Integer;
    FWantReturns: Boolean;
    FWantTabs: Boolean;
    FWordWrap: Boolean;

    FOnChange: TNotifyEvent;
    FOnLinkClick: TAutoRichEditLinkClick;
    FOnProtectChange: TAutoRichEditProtectChange;
    FOnResizeRequest: TAutoRichEditResizeEvent;
    FOnSaveClipboard: TAutoRichEditSaveClipboard;
    FOnSelectionChange: TNotifyEvent;

    MouseAboveLink: Boolean;
    PrevAutoURLDetect, PrevModified, PrevPlainText: Boolean;
    PrevSelStart: Integer;
    TempStream: TMemoryStream;

    { IUnknown }
    {$IFNDEF DELPHI4}
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    {$ENDIF}
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    { IRichEditOleCallback }
    function GetNewStorage(out stg: IStorage): HResult; stdcall;
    function GetInPlaceContext(out Frame: IOleInPlaceFrame;
      out Doc: IOleInPlaceUIWindow;
      lpFrameInfo: POleInPlaceFrameInfo): HResult; stdcall;
    function ShowContainerUI(fShow: BOOL): HResult; stdcall;
    function QueryInsertObject(const clsid: TCLSID;
      const stg: IStorage; cp: Longint): HResult; stdcall;
    function DeleteObject(const oleobj: IOleObject): HResult; stdcall;
    function QueryAcceptData(const dataobj: IDataObject;
      var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
      hMetaPict: HGLOBAL): HResult; stdcall;
    function IRichEditOleCallback.ContextSensitiveHelp = RichEditOleCallback_ContextSensitiveHelp;
    function RichEditOleCallback_ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    function GetClipboardData(const chrg: TCharRange; reco: DWORD;
      out dataobj: IDataObject): HResult; stdcall;
    function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
      var dwEffect: DWORD): HResult; stdcall;
    function GetContextMenu(seltype: Word; const oleobj: IOleObject;
      const chrg: TCharRange; out menu: HMENU): HResult; stdcall;

    { IOleWindow }
    function GetWindow(out wnd: HWND): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

    { IOleInPlaceUIWindow }
    function GetBorder(out rectBorder: TRect): HResult; stdcall;
    function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
    function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
    function SetActiveObject(const activeObject: IOleInPlaceActiveObject;
      pszObjName: POleStr): HResult; stdcall;

    { IOleInPlaceFrame }
    function InsertMenus(hmenuShared: HMenu;
      var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
    function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
      hwndActiveObject: HWnd): HResult; stdcall;
    function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
    function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
    function TranslateAccelerator(var msg: TMsg; wID: Word): HResult; stdcall;

    { TCustomAutoRichEdit }
    function AppHook(var Message: TMessage): Boolean;
    procedure FindOne(Sender: TObject);
    function GetMainForm: TCustomForm;
    function GetMainMenu: TMainMenu;
    procedure MainFormClose(Sender: TObject; var Action: TCloseAction);
    procedure ParentFormClose(Sender: TObject; var Action: TCloseAction);
    procedure ReplaceOne(Sender: TObject);
    procedure VerbPopupMenuClick(Sender: TObject);

    function GetAutoURLDetect: Boolean;
    function GetCanPaste: Boolean;
    function GetCanRedo: Boolean;
    function GetCanUndo: Boolean;