richedit2.pas

类似QQ的源码程序

unit RichEdit2;

{
  RichEdit98 and DBRichEdit98 components for Delphi 3.0-4.0. version 1.40
  Author Alexander Obukhov, Minsk, Belarus <[e-mail]>

  OLE support code written by
    Greg Chapman <[e-mail]>
    Mike Lindre <[e-mail]>
    Tomasz Kustra <[e-mail]>
    Sigi <[e-mail]>

  Thanks to:
    Oliver Matla <[e-mail]>
    Glenn Benes <[e-mail]>
    Sven Opitz <[e-mail]>
    Jolios Lin <[e-mail]>
    Tom Wang <[e-mail]>
    Doron Tal <[e-mail]>
    Alexander Halser <[e-mail]>
    Arentjan Banck <[e-mail]>
    Andre Van Der Merwe <[e-mail]>
    Iain Magee <[e-mail]>
    Sigi <[e-mail]>
    Rob Schoenaker <[e-mail]>
    Laszlo Kovacs <[e-mail]>
}

interface

uses
    Langs, WStrList,
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    StdCtrls, ComCtrls, ComStrs, RichEdit,
    {$ifdef BDE_SUPPORT}
    DB, DBCtrls,
    {$endif}
    ActiveX,OleCtnrs,olectrls,ComObj,OleDlg,RichOle,Menus, Printers;

const
  FT_DOWNWARD = 1;
  DataFormatCount = 2;

var
  CF_RTF: Cardinal = 0;
  CF_RTFNOOBJS: Cardinal = 0;
  CF_RETEXTOBJ: Cardinal = 0;

type
{ The declarations of TTextRangeA and TTextRangeW in Richedit.pas are incorrect}
  TTextRangeA = record
    chrg: TCharRange;
    lpstrText: PAnsiChar; {not AnsiChar!}
  end;

  TTextRangeW = record
    chrg: TCharRange;
    lpstrText: PWideChar; {not WideChar!}
  end;

  TTextRange = TTextRangeA;

  TInputFormat=(ifText, ifRTF, ifUnicode);
  TOutputFormat=(ofText, ofRTF, ofRTFNoObjs, ofTextized, ofUnicode);

  TSearchType98 = (stBackward, stWholeWord, stMatchCase);
  TSearchTypes98 = set of TSearchType98;

  TCustomRichEdit98 = class;

  TConsistentAttribute98 = (caBold, caColor, caFace, caItalic,
    caSize, caStrikeOut, caUnderline, caProtected, caWeight,
    caBackColor, caLanguage, caIndexKind, caOffset, caSpacing,
    caKerning, caULType, caAnimation, caSmallCaps, caAllCaps,
    caHidden, caOutline, caShadow, caEmboss, caImprint, caURL);
  TConsistentAttributes98 = set of TConsistentAttribute98;

  TIndexKind = (ikNone, ikSubscript, ikSuperscript);

  TUnderlineType = (ultNone, ultSingle, ultWord, ultDouble, ultDotted, ultWave,
                    ultThick, ultHair, ultDashDD, ultDashD, ultDash);

  TAnimationType = (aniNone, aniLasVegas, aniBlink, aniSparkle, aniBlackAnts,
                    aniRedAnts, aniShimmer);

  TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
  private
    FOwner: TCustomRichEdit98;
  protected
    function GetNewStorage(out stg: IStorage): HRESULT; stdcall;
    function GetInPlaceContext(out Frame: IOleInPlaceFrame;
         out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo): HRESULT; stdcall;
    function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;
    function QueryInsertObject(const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT; stdcall;
    function DeleteObject(oleobj: IOLEObject): HRESULT; stdcall;
    function QueryAcceptData(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; oleobj: IOleObject;
         const chrg: TCharRange; var menu: HMENU): HRESULT; stdcall;
  public
    constructor Create(AOwner: TCustomRichEdit98);
  end;


  TTextAttributes98 = class(TPersistent)
  private
    RichEdit: TCustomRichEdit98;
    FType: TAttributeType;
    FOldAttr: TTextattributes;
    procedure GetAttributes(var Format: TCharFormat2W);
    function GetConsistentAttributes: TConsistentAttributes98;
    procedure SetAttributes(var Format: TCharFormat2W);
  protected
    procedure InitFormat(var Format: TCharFormat2W);
    procedure AssignTo(Dest: TPersistent); override;
    function GetColor: TColor;
    procedure SetColor(Value: TColor);
    function GetName: TFontName;
    procedure SetName(Value: TFontName);
    function GetPitch: TFontPitch;
    procedure SetPitch(Value: TFontPitch);
    function GetProtected: Boolean;
    procedure SetProtected(Value: Boolean);
    function GetSize: Integer;
    procedure SetSize(Value: Integer);
    function GetHeight: Integer;
    procedure SetHeight(Value: Integer);
    function GetWeight: Word;
    procedure SetWeight(Value: Word);
    function GetBackColor: TColor;
    procedure SetBackColor(Value: TColor);
    function GetLanguage: TLanguage;
    procedure SetLanguage(Value: TLanguage);
    function GetIndexKind: TIndexKind;
    procedure SetIndexKind(Value: TIndexKind);
    function GetOffset: Double;
    procedure SetOffset(Value: Double);
    function GetSpacing: Double;
    procedure SetSpacing(Value: Double);
    function GetKerning: Double;
    procedure SetKerning(Value: Double);
    function GetUnderlineType: TUnderlineType;
    procedure SetUnderlineType(Value: TUnderlineType);
    function GetAnimation: TAnimationType;
    procedure SetAnimation(Value: TAnimationType);
    function GetBold: Boolean;
    procedure SetBold(Value: Boolean);
    function GetItalic: Boolean;
    procedure SetItalic(Value: Boolean);
    function GetStrikeOut: Boolean;
    procedure SetStrikeOut(Value: Boolean);
    function GetSmallCaps: Boolean;
    procedure SetSmallCaps(Value: Boolean);
    function GetAllCaps: Boolean;
    procedure SetAllCaps(Value: Boolean);
    function GetHidden: Boolean;
    procedure SetHidden(Value: Boolean);
    function GetOutline: Boolean;
    procedure SetOutline(Value: Boolean);
    function GetShadow: Boolean;
    procedure SetShadow(Value: Boolean);
    function GetEmboss: Boolean;
    procedure SetEmboss(Value: Boolean);
    function GetImprint: Boolean;
    procedure SetImprint(Value: Boolean);
    function GetStyle: TFontStyles;
    procedure SetStyle(Value: TFontStyles);
    function GetIsURL: Boolean;
    procedure SetIsURL(Value: Boolean);
  public
    constructor Create(AOwner: TCustomRichEdit98; AttributeType: TAttributeType);
    procedure Assign(Source: TPersistent); override;
    property ConsistentAttributes: TConsistentAttributes98 read GetConsistentAttributes;
    property Color: TColor read GetColor write SetColor;
    property Name: TFontName read GetName write SetName;
    property Pitch: TFontPitch read GetPitch write SetPitch;
    property Protected: Boolean read GetProtected write SetProtected;
    property Size: Integer read GetSize write SetSize;
    property Height: Integer read GetHeight write SetHeight;
    property Weight: Word read GetWeight write SetWeight;
    property BackColor: TColor read GetBackColor write SetBackColor;
    property Language: TLanguage read GetLanguage write SetLanguage;
    property IndexKind: TIndexKind read GetIndexKind write SetIndexKind;
    property Offset: Double read GetOffset write SetOffset;
    property Spacing: Double read GetSpacing write SetSpacing;
    property Kerning: Double read GetKerning write SetKerning;
    property UnderlineType: TUnderlineType read GetUnderlineType write SetUnderlineType;
    property Animation: TAnimationType read GetAnimation write SetAnimation;
    property Bold: Boolean read GetBold write SetBold;
    property Italic: Boolean read GetItalic write SetItalic;
    property StrikeOut: Boolean read GetStrikeOut write SetStrikeOut;
    property SmallCaps: Boolean read GetSmallCaps write SetSmallCaps;
    property AllCaps: Boolean read GetAllCaps write SetAllCaps;
    property Hidden: Boolean read GetHidden write SetHidden;
    property Outline: Boolean read GetOutline write SetOutline;
    property Shadow: Boolean read GetShadow write SetShadow;
    property Emboss: Boolean read GetEmboss write SetEmboss;
    property Imprint: Boolean read GetImprint write SetImprint;
    property Style: TFontStyles read GetStyle write SetStyle;
    property IsURL: Boolean read GetIsURL write SetIsURL;
  end;

  TLineSpacingRule = (lsrOrdinary, lsr15, lsrDouble, lsrAtLeast, lsrExactly,
                      lsrMultiple);

  TAlignment98 = (taLeft, taRight, taCenter, taJustify);

  TNumberingStyle98 = (nsNone, nsBullet, nsNumber, nsLowerCase, nsUpperCase,
                       nsLowerRoman, nsUpperRoman, nsSequence);

  TNumberingFollow = (nfParenthesis, nfPeriod, nfEncloseParenthesis);

  TBorderLocation = (blLeft, blRight, blTop, blBottom, blInside, blOutside);
  TBorderLocations = set of TBorderLocation;

  TBorderStyle = (bsNone, bs15, bs30, bs45, bs60, bs90, bs120, bs15Dbl,
                  bs30Dbl, bs45Dbl, bs15Gray, bs15GrayDashed);

  TShadingWeight = 0..100;

  TShadingStyle = (shsNone, shsDarkHorizontal, shsDarkVertical, shsDarkDownDiagonal,
                   shsDarkUpDiagonal, shsDarkGrid, shsDarkTrellis, shsLightHorizontal,
                   shsLightVertical, shsLightDownDiagonal, shsLightUpDiagonal,
                   shsLightGrid, shsLightTrellis);

  TTabAlignment = (tbaLeft, tbaCenter, tbaRight, tbaDecimal, tbaWordBar);

  TTabLeader = (tblNone, tblDotted, tblDashed, tblUnderlined, tblThick, tblDouble);

  TParaAttributes98 = class(TParaAttributes)
  private
    RichEdit: TCustomRichEdit98;
    procedure GetAttributes(var Paragraph: TParaFormat2);
    procedure InitPara(var Paragraph: TParaFormat2);
    procedure SetAttributes(var Paragraph: TParaFormat2);
    function GetFirstIndent: Double;
    procedure SetFirstIndent(Value: Double);
    function GetLeftIndent: Double;
    procedure SetLeftIndent(Value: Double);
    function GetRightIndent: Double;
    procedure SetRightIndent(Value: Double);
    function GetSpaceBefore: Double;
    procedure SetSpaceBefore(Value: Double);
    function GetSpaceAfter: Double;
    procedure SetSpaceAfter(Value: Double);
    function GetLineSpacing: Double;
    function GetLineSpacingRule: TLineSpacingRule;
    function GetKeepTogether: Boolean;
    procedure SetKeepTogether(Value: Boolean);
    function GetKeepWithNext: Boolean;
    procedure SetKeepWithNext(Value: Boolean);
    function GetPageBreakBefore: Boolean;
    procedure SetPageBreakBefore(Value: Boolean);
    function GetNoLineNumber: Boolean;
    procedure SetNoLineNumber(Value: Boolean);
    function GetNoWidowControl: Boolean;
    procedure SetNoWidowControl(Value: Boolean);
    function GetDoNotHyphen: Boolean;
    procedure SetDoNotHyphen(Value: Boolean);
    function GetSideBySide: Boolean;
    procedure SetSideBySide(Value: Boolean);
    function GetAlignment: TAlignment98;
    procedure SetAlignment(Value: TAlignment98);
    function GetNumbering: TNumberingStyle98;
    procedure SetNumbering(Value: TNumberingStyle98);
    function GetNumberingStart: Word;
    procedure SetNumberingStart(Value: Word);
    function GetNumberingFollow: TNumberingFollow;
    procedure SetNumberingFollow(Value: TNumberingFollow);
    function GetNumberingTab: Double;
    procedure SetNumberingTab(Value: Double);
    function GetBorderSpace: Double;
    function GetBorderWidth: Double;
    function GetBorderLocations: TBorderLocations;
    function GetBorderStyle: TBorderStyle;
    function GetBorderColor: TColor;
    function GetShadingWeight: TShadingWeight;
    function GetShadingStyle: TShadingStyle;
    function GetShadingColor: TColor;
    function GetShadingBackColor: TColor;
    function GetTabCount: Integer;
    function GetTab(Index: Integer): Double;
    function GetTabAlignment(Index: Integer): TTabAlignment;
    function GetTabLeader(Index: Integer): TTabLeader;
  public
    constructor Create(AOwner: TCustomRichEdit98);
    property Alignment: TAlignment98 read GetAlignment write SetAlignment;
    property FirstIndent: Double read GetFirstIndent write SetFirstIndent;
    property LeftIndent: Double read GetLeftIndent write SetLeftIndent;
    property RightIndent: Double read GetRightIndent write SetRightIndent;
    property SpaceBefore: Double read GetSpaceBefore write SetSpaceBefore;
    property SpaceAfter: Double read GetSpaceAfter write SetSpaceAfter;
    procedure SetLineSpacing(Rule: TLineSpacingRule; Value: Double);
    property LineSpacing: Double read GetLineSpacing;
    property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule;
    property KeepTogether: Boolean read GetKeepTogether write SetKeepTogether;
    property KeepWithNext: Boolean read GetKeepWithNext write SetKeepWithNext;
    property PageBreakBefore: Boolean read GetPageBreakBefore write SetPageBreakBefore;
    property NoLineNumber: Boolean read GetNoLineNumber write SetNoLineNumber;
    property NoWidowControl: Boolean read GetNoWidowControl write SetNoWidowControl;
    property DoNotHyphen: Boolean read GetDoNotHyphen write SetDoNotHyphen;
    property SideBySide: Boolean read GetSideBySide write SetSideBySide;
    property Numbering: TNumberingStyle98 read GetNumbering write SetNumbering;
    property NumberingStart: Word read GetNumberingStart write SetNumberingStart;
    property NumberingFollow: TNumberingFollow read GetNumberingFollow write SetNumberingFollow;
    property NumberingTab: Double read GetNumberingTab write SetNumberingTab;
    property BorderSpace: Double read GetBorderSpace;
    property BorderWidth: Double read GetBorderWidth;
    property BorderLocations: TBorderLocations read GetBorderLocations;
    property BorderStyle: TBorderStyle read GetBorderStyle;
    property BorderColor: TColor read GetBorderColor;
    procedure SetBorder(Space, Width: Double; Locations: TBorderLocations;
                        Style: TBorderStyle; Color: TColor);
    property ShadingWeight: TShadingWeight read GetShadingWeight;
    property ShadingStyle: TShadingStyle read GetShadingStyle;
    property ShadingColor: TColor read GetShadingColor;
    property ShadingBackColor: TColor read GetShadingBackColor;
    procedure SetShading(Weight: TShadingWeight; Style: TShadingStyle;
                         Color, BackColor: TColor);
    property TabCount: Integer read GetTabCount;
    property Tab[Index: Integer]: Double read GetTab;
    property TabAlignment[Index: Integer]: TTabAlignment read GetTabAlignment;
    property TabLeader[Index: Integer]: TTabLeader read GetTabLeader;
    procedure SetTab(Index: Integer; Value: Double; Alignment: TTabAlignment;
                     Leader: TTabLeader);
  end;

  TURLClickEvent = procedure(Sender: TObject; URL: String) of object;
  TURLMoveEvent = procedure(Sender: TObject; URL: String) of object;
  TRichEditProgressEvent = procedure(Sender: TObject; Pos, Size: Integer) of object;

  TUndoName = (unUnknown, unTyping, unDelete, unDragDrop, unCut, unPaste);

  TLangOption = (loAutoKeyboard, loAutoFont, loIMECancelComplete, loIMEAlwaysSendNotify);
  TLangOptions = set of TLangOption;

  TSelType = (stText, stObject, stMultiChar, stMultiObject);
  TSelectionType = set of TSelType;

  TAutoURLDetect = (adNone, adDefault, adExtended);

  TURLType = class(TCollectionItem)
  private
    FName: String;
    FColor: TColor;
    FCursor: Tcursor;
    FUnderline: Boolean;
  protected
    function GetDisplayName: string; override;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Name: String read FName write FName;
    property Color: TColor read FColor write FColor;
    property Cursor: TCursor read FCursor write FCursor;
    property Underline: Boolean read FUnderline write FUnderline;
  end;

  {$WARNINGS OFF}
  TURLCollection = class(TCollection)
  private
    FOwner: TCustomRichEdit98;
  protected
    function GetOwner: TPersistent; override;
    procedure SetItems(Index: Integer; Value: TURLType);
    function GetItems(Index: Integer): TURLType;
  public
    procedure AddURLType(const Name: String; Color: TColor;
                         Cursor: TCursor; Underline: Boolean);
    property Owner: TCustomRichEdit98 read FOwner;
    property Items[Index: Integer]: TURLType read GetItems write SetItems; default;
  end;
  {$WARNINGS ON}

  TCustomRichEdit98 = class(TCustomRichEdit)
  private
    { Private declarations }
    FUpdateCount: Integer;
    FLibHandle: THandle;
    FSelAttributes: TTextAttributes98;
    FDefAttributes: TTextAttributes98;
    FParagraph: TParaAttributes98;
    FRichEditStrings: TStrings;
    FWideStrings: TWideStrings;
    FScreenLogPixels: Integer;
    FAutoURLDetect: TAutoURLDetect;
    FShowSelBar: Boolean;
    FOnURLClick: TURLClickEvent;
    FOnURLMove: TURLMoveEvent;
    FOnSaveProgress: TRichEditProgressEvent;
    FOnLoadProgress: TRichEditProgressEvent;
    FURLColor: TColor;
    FURLCursor: TCursor;
    FLanguage: TLanguage;
    FCP: Word;
    FWide: Boolean;
    FStreamSel: Boolean;
    FStoreSS,
    FStoreSL,
    FStoreFVL: Integer;
    FCROld: TCharRange;
    FVer10: Boolean;
//    FPlainText: Boolean;
    FLangOptions: TLangOptions;
    FDefWndProcW: TFNWndProc;
    FDefWndProcA: TFNWndProc;
    FURLs: TURLCollection;
    FWordFormatting: Boolean;
    FUndoLimit: Integer;

    FPlainTextIn: TInputFormat;
    FPlainTextOut: TOutputFormat;
    FSelectedInOut: Boolean;
    FPlainRTF: Boolean;

    FPopupVerbMenu: TPopupMenu;
    FAutoVerbMenu: Boolean;
    FObjectVerbs: TStringList;
    FSelObject: IOleObject;
    FDrawAspect: Longint;
    FViewSize: TPoint;
    FIncludeOLE:Boolean;
    FAllowInPlace: Boolean;
    procedure DestroyVerbs;
    procedure UpdateVerbs;
    procedure PopupVerbMenuClick(Sender: TObject);
    procedure DoVerb(Verb: Integer);
    function GetCanPaste: Boolean;

    procedure UpdateObject;
    procedure UpdateView;
    procedure SetIncludeOLE(Value:Boolean);
    function GetIconMetaPict: HGlobal;
    procedure CheckObject;
    procedure SetDrawAspect(Iconic: Boolean; IconMetaPict: HGlobal);
    property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;

    procedure SetDefAttributes(Value: TTextAttributes98);
    procedure SetSelAttributes(Value: TTextAttributes98);
    procedure SetShowSelBar(Value: Boolean);
    procedure SetRichEditStrings(Value: TStrings);