Delphi控件源码

开发平台：

Delphi

RxRichEd.pas：源码内容

{*******************************************************}
{ }
{ Delphi VCL Extensions (RX) }
{ }
{ }
{*******************************************************}
unit RxRichEd;
{$I RX.INC}
{.$DEFINE RICHEDIT_VER_10}
{$R-}
interface
uses Windows, {$IFDEF RX_D3} ActiveX, ComObj {$ELSE} Ole2, OleAuto {$ENDIF},
CommCtrl, Messages, SysUtils, Classes, Controls, Forms, Graphics, StdCtrls,
Dialogs, RichEdit, Menus, ComCtrls;
type
TRichEditVersion = 1..3;
{$IFNDEF RX_D3}
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;
TParaFormat2 = record
cbSize: UINT;
dwMask: DWORD;
wNumbering: Word;
wReserved: Word;
dxStartIndent: Longint;
dxRightIndent: Longint;
dxOffset: Longint;
wAlignment: Word;
cTabCount: Smallint;
rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;
{ new fields in version 2.0 }
dySpaceBefore: Longint; { Vertical spacing before paragraph }
dySpaceAfter: Longint; { Vertical spacing after paragraph }
dyLineSpacing: Longint; { Line spacing depending on Rule }
sStyle: Smallint; { Style handle }
bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) }
bCRC: Byte; { Reserved for CRC for rapid searching }
wShadingWeight: Word; { Shading in hundredths of a per cent }
wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat }
wNumberingStart: Word; { Starting value for numbering }
wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc.}
wNumberingTab: Word; { Space bet 1st indent and 1st-line text }
wBorderSpace: Word; { Space between border and text (twips) }
wBorderWidth: Word; { Border pen width (twips) }
wBorders: Word; { Byte 0: bits specify which borders }
{ Nibble 2: border style, 3: color index }
end;
{$ENDIF RX_D3}
{$IFDEF RX_D5}
TCharFormat2 = TCharFormat2A;
{$ENDIF}
type
TRxCustomRichEdit = class;
{ TRxTextAttributes }
TRxAttributeType = (atDefaultText, atSelected, atWord);
TRxConsistentAttribute = (caBold, caColor, caFace, caItalic, caSize,
caStrikeOut, caUnderline, caProtected, caOffset, caHidden, caLink,
caBackColor, caDisabled, caWeight, caSubscript, caRevAuthor);
TRxConsistentAttributes = set of TRxConsistentAttribute;
TSubscriptStyle = (ssNone, ssSubscript, ssSuperscript);
TUnderlineType = (utNone, utSolid, utWord, utDouble, utDotted, utWave);
TRxTextAttributes = class(TPersistent)
private
RichEdit: TRxCustomRichEdit;
FType: TRxAttributeType;
procedure AssignFont(Font: TFont);
procedure GetAttributes(var Format: TCharFormat2);
{$IFNDEF VER90}
function GetCharset: TFontCharset;
procedure SetCharset(Value: TFontCharset);
{$ENDIF}
function GetSubscriptStyle: TSubscriptStyle;
procedure SetSubscriptStyle(Value: TSubscriptStyle);
function GetBackColor: TColor;
function GetColor: TColor;
function GetConsistentAttributes: TRxConsistentAttributes;
function GetHeight: Integer;
function GetHidden: Boolean;
function GetDisabled: Boolean;
function GetLink: Boolean;
function GetName: TFontName;
function GetOffset: Integer;
function GetPitch: TFontPitch;
function GetProtected: Boolean;
function GetRevAuthorIndex: Byte;
function GetSize: Integer;
function GetStyle: TFontStyles;
function GetUnderlineType: TUnderlineType;
procedure SetAttributes(var Format: TCharFormat2);
procedure SetBackColor(Value: TColor);
procedure SetColor(Value: TColor);
procedure SetDisabled(Value: Boolean);
procedure SetHeight(Value: Integer);
procedure SetHidden(Value: Boolean);
procedure SetLink(Value: Boolean);
procedure SetName(Value: TFontName);
procedure SetOffset(Value: Integer);
procedure SetPitch(Value: TFontPitch);
procedure SetProtected(Value: Boolean);
procedure SetRevAuthorIndex(Value: Byte);
procedure SetSize(Value: Integer);
procedure SetStyle(Value: TFontStyles);
procedure SetUnderlineType(Value: TUnderlineType);
protected
procedure InitFormat(var Format: TCharFormat2);
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create(AOwner: TRxCustomRichEdit; AttributeType: TRxAttributeType);
procedure Assign(Source: TPersistent); override;
{$IFNDEF VER90}
property Charset: TFontCharset read GetCharset write SetCharset;
{$ENDIF}
property BackColor: TColor read GetBackColor write SetBackColor;
property Color: TColor read GetColor write SetColor;
property ConsistentAttributes: TRxConsistentAttributes read GetConsistentAttributes;
property Disabled: Boolean read GetDisabled write SetDisabled;
property Hidden: Boolean read GetHidden write SetHidden;
property Link: Boolean read GetLink write SetLink;
property Name: TFontName read GetName write SetName;
property Offset: Integer read GetOffset write SetOffset;
property Pitch: TFontPitch read GetPitch write SetPitch;
property Protected: Boolean read GetProtected write SetProtected;
property RevAuthorIndex: Byte read GetRevAuthorIndex write SetRevAuthorIndex;
property SubscriptStyle: TSubscriptStyle read GetSubscriptStyle write SetSubscriptStyle;
property Size: Integer read GetSize write SetSize;
property Style: TFontStyles read GetStyle write SetStyle;
property Height: Integer read GetHeight write SetHeight;
property UnderlineType: TUnderlineType read GetUnderlineType write SetUnderlineType;
end;
{ TRxParaAttributes }
TRxNumbering = (nsNone, nsBullet, nsArabicNumbers, nsLoCaseLetter,
nsUpCaseLetter, nsLoCaseRoman, nsUpCaseRoman);
TRxNumberingStyle = (nsParenthesis, nsPeriod, nsEnclosed, nsSimple);
TParaAlignment = (paLeftJustify, paRightJustify, paCenter, paJustify);
TLineSpacingRule = (lsSingle, lsOneAndHalf, lsDouble, lsSpecifiedOrMore,
lsSpecified, lsMultiple);
THeadingStyle = 0..9;
TParaTableStyle = (tsNone, tsTableRow, tsTableCellEnd, tsTableCell);
TRxParaAttributes = class(TPersistent)
private
RichEdit: TRxCustomRichEdit;
procedure GetAttributes(var Paragraph: TParaFormat2);
function GetAlignment: TParaAlignment;
function GetFirstIndent: Longint;
function GetHeadingStyle: THeadingStyle;
function GetLeftIndent: Longint;
function GetRightIndent: Longint;
function GetSpaceAfter: Longint;
function GetSpaceBefore: Longint;
function GetLineSpacing: Longint;
function GetLineSpacingRule: TLineSpacingRule;
function GetNumbering: TRxNumbering;
function GetNumberingStyle: TRxNumberingStyle;
function GetNumberingTab: Word;
function GetTab(Index: Byte): Longint;
function GetTabCount: Integer;
function GetTableStyle: TParaTableStyle;
procedure SetAlignment(Value: TParaAlignment);
procedure SetAttributes(var Paragraph: TParaFormat2);
procedure SetFirstIndent(Value: Longint);
procedure SetHeadingStyle(Value: THeadingStyle);
procedure SetLeftIndent(Value: Longint);
procedure SetRightIndent(Value: Longint);
procedure SetSpaceAfter(Value: Longint);
procedure SetSpaceBefore(Value: Longint);
procedure SetLineSpacing(Value: Longint);
procedure SetLineSpacingRule(Value: TLineSpacingRule);
procedure SetNumbering(Value: TRxNumbering);
procedure SetNumberingStyle(Value: TRxNumberingStyle);
procedure SetNumberingTab(Value: Word);
procedure SetTab(Index: Byte; Value: Longint);
procedure SetTabCount(Value: Integer);
procedure SetTableStyle(Value: TParaTableStyle);
protected
procedure InitPara(var Paragraph: TParaFormat2);
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create(AOwner: TRxCustomRichEdit);
procedure Assign(Source: TPersistent); override;
property Alignment: TParaAlignment read GetAlignment write SetAlignment;
property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
property HeadingStyle: THeadingStyle read GetHeadingStyle write SetHeadingStyle;
property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
property LineSpacing: Longint read GetLineSpacing write SetLineSpacing;
property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule write SetLineSpacingRule;
property Numbering: TRxNumbering read GetNumbering write SetNumbering;
property NumberingStyle: TRxNumberingStyle read GetNumberingStyle write SetNumberingStyle;
property NumberingTab: Word read GetNumberingTab write SetNumberingTab;
property RightIndent: Longint read GetRightIndent write SetRightIndent;
property SpaceAfter: Longint read GetSpaceAfter write SetSpaceAfter;
property SpaceBefore: Longint read GetSpaceBefore write SetSpaceBefore;
property Tab[Index: Byte]: Longint read GetTab write SetTab;
property TabCount: Integer read GetTabCount write SetTabCount;
property TableStyle: TParaTableStyle read GetTableStyle write SetTableStyle;
end;
{ TOEMConversion }
TOEMConversion = class(TConversion)
public
function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; override;
function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; override;
end;
{ TRxCustomRichEdit }
TUndoName = (unUnknown, unTyping, unDelete, unDragDrop, unCut, unPaste);
TRichSearchType = (stWholeWord, stMatchCase, stBackward, stSetSelection);
TRichSearchTypes = set of TRichSearchType;
TRichSelection = (stText, stObject, stMultiChar, stMultiObject);
TRichSelectionType = set of TRichSelection;
TRichLangOption = (rlAutoKeyboard, rlAutoFont, rlImeCancelComplete,
rlImeAlwaysSendNotify);
TRichLangOptions = set of TRichLangOption;
TRichStreamFormat = (sfDefault, sfRichText, sfPlainText);
TRichStreamMode = (smSelection, smPlainRtf, smNoObjects, smUnicode);
TRichStreamModes = set of TRichStreamMode;
TRichEditURLClickEvent = procedure(Sender: TObject; const URLText: string;
Button: TMouseButton) of object;
TRichEditProtectChangeEx = procedure(Sender: TObject; const Message: TMessage;
StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
TRichEditFindErrorEvent = procedure(Sender: TObject; const FindText: string) of object;
{$IFDEF RX_D3}
TRichEditFindCloseEvent = procedure(Sender: TObject; Dialog: TFindDialog) of object;
{$ENDIF}
PRichConversionFormat = ^TRichConversionFormat;
TRichConversionFormat = record
ConversionClass: TConversionClass;
Extension: string;
PlainText: Boolean;
Next: PRichConversionFormat;
end;
TRxCustomRichEdit = class(TCustomMemo)
private
FHideScrollBars: Boolean;
FSelectionBar: Boolean;
FAutoURLDetect: Boolean;
FWordSelection: Boolean;
FPlainText: Boolean;
FSelAttributes: TRxTextAttributes;
FDefAttributes: TRxTextAttributes;
FWordAttributes: TRxTextAttributes;
FParagraph: TRxParaAttributes;
FOldParaAlignment: TParaAlignment;
FScreenLogPixels: Integer;
FUndoLimit: Integer;
FRichEditStrings: TStrings;
FMemStream: TMemoryStream;
FHideSelection: Boolean;
FLangOptions: TRichLangOptions;
FModified: Boolean;
FLinesUpdating: Boolean;
FPageRect: TRect;
FClickRange: TCharRange;
FClickBtn: TMouseButton;
FFindDialog: TFindDialog;
FReplaceDialog: TReplaceDialog;
FLastFind: TFindDialog;
FAllowObjects: Boolean;
FCallback: TObject;
FRichEditOle: IUnknown;
FPopupVerbMenu: TPopupMenu;
FTitle: string;
FAutoVerbMenu: Boolean;
{$IFDEF RX_D3}
FAllowInPlace: Boolean;
{$ENDIF}
FDefaultConverter: TConversionClass;
FOnSelChange: TNotifyEvent;
FOnResizeRequest: TRichEditResizeEvent;
FOnProtectChange: TRichEditProtectChange;
FOnProtectChangeEx: TRichEditProtectChangeEx;
FOnSaveClipboard: TRichEditSaveClipboard;
FOnURLClick: TRichEditURLClickEvent;
FOnTextNotFound: TRichEditFindErrorEvent;
{$IFDEF RX_D3}
FOnCloseFindDialog: TRichEditFindCloseEvent;
{$ENDIF}
function GetAutoURLDetect: Boolean;
function GetWordSelection: Boolean;
function GetLangOptions: TRichLangOptions;
function GetCanRedo: Boolean;
function GetCanPaste: Boolean;
{$IFNDEF RX_V110}
function GetCanUndo: Boolean;
{$ENDIF}
function GetRedoName: TUndoName;
function GetUndoName: TUndoName;
function GetStreamFormat: TRichStreamFormat;
function GetStreamMode: TRichStreamModes;
function GetSelectionType: TRichSelectionType;
procedure PopupVerbClick(Sender: TObject);
procedure ObjectPropsClick(Sender: TObject);
procedure CloseObjects;
procedure UpdateHostNames;
procedure SetAllowObjects(Value: Boolean);
procedure SetStreamFormat(Value: TRichStreamFormat);
procedure SetStreamMode(Value: TRichStreamModes);
procedure SetAutoURLDetect(Value: Boolean);
procedure SetWordSelection(Value: Boolean);
procedure SetHideScrollBars(Value: Boolean);
procedure SetHideSelection(Value: Boolean);
procedure SetTitle(const Value: string);
procedure SetLangOptions(Value: TRichLangOptions);
procedure SetRichEditStrings(Value: TStrings);
procedure SetDefAttributes(Value: TRxTextAttributes);
procedure SetSelAttributes(Value: TRxTextAttributes);
procedure SetWordAttributes(Value: TRxTextAttributes);
procedure SetSelectionBar(Value: Boolean);
procedure SetUndoLimit(Value: Integer);
procedure UpdateTextModes(Plain: Boolean);
procedure AdjustFindDialogPosition(Dialog: TFindDialog);
procedure SetupFindDialog(Dialog: TFindDialog; const SearchStr,
ReplaceStr: string);
function FindEditText(Dialog: TFindDialog; AdjustPos, Events: Boolean): Boolean;
function GetCanFindNext: Boolean;
procedure FindDialogFind(Sender: TObject);
procedure ReplaceDialogReplace(Sender: TObject);
{$IFDEF RX_D3}
procedure FindDialogClose(Sender: TObject);
procedure SetUIActive(Active: Boolean);
procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
{$ENDIF}
{$IFDEF RX_D4}
procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
{$ENDIF}
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure EMReplaceSel(var Message: TMessage); message EM_REPLACESEL;
procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;
procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
{$IFDEF RX_D5}
procedure WMRButtonUp(var Message: TMessage); message WM_RBUTTONUP;
{$ENDIF}
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWindowHandle(const Params: TCreateParams); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
function GetPopupMenu: TPopupMenu; override;
procedure TextNotFound(Dialog: TFindDialog); virtual;
procedure RequestSize(const Rect: TRect); virtual;
procedure SelectionChange; dynamic;
function ProtectChange(const Message: TMessage; StartPos,
EndPos: Integer): Boolean; dynamic;
function SaveClipboard(NumObj, NumChars: Integer): Boolean; dynamic;
procedure URLClick(const URLText: string; Button: TMouseButton); dynamic;
procedure SetPlainText(Value: Boolean); virtual;
{$IFDEF RX_D3}
procedure CloseFindDialog(Dialog: TFindDialog); virtual;
procedure DoSetMaxLength(Value: Integer); override;
function GetSelLength: Integer; override;
function GetSelStart: Integer; override;
function GetSelText: string; override;
procedure SetSelLength(Value: Integer); override;
procedure SetSelStart(Value: Integer); override;
property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;
{$ENDIF}
property AllowObjects: Boolean read FAllowObjects write SetAllowObjects default True;
property AutoURLDetect: Boolean read GetAutoURLDetect write SetAutoURLDetect default True;
property AutoVerbMenu: Boolean read FAutoVerbMenu write FAutoVerbMenu default True;
property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
property HideScrollBars: Boolean read FHideScrollBars
write SetHideScrollBars default True;
property Title: string read FTitle write SetTitle;
property LangOptions: TRichLangOptions read GetLangOptions write SetLangOptions default [rlAutoFont];
property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
property PlainText: Boolean read FPlainText write SetPlainText default False;
property SelectionBar: Boolean read FSelectionBar write SetSelectionBar default True;
property StreamFormat: TRichStreamFormat read GetStreamFormat write SetStreamFormat default sfDefault;
property StreamMode: TRichStreamModes read GetStreamMode write SetStreamMode default [];
property UndoLimit: Integer read FUndoLimit write SetUndoLimit default 100;
property WordSelection: Boolean read GetWordSelection write SetWordSelection default True;
property ScrollBars default ssBoth;
property TabStop default True;
property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard
write FOnSaveClipboard;
property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;
property OnProtectChange: TRichEditProtectChange read FOnProtectChange
write FOnProtectChange; { obsolete }
property OnProtectChangeEx: TRichEditProtectChangeEx read FOnProtectChangeEx
write FOnProtectChangeEx;
property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest
write FOnResizeRequest;
property OnURLClick: TRichEditURLClickEvent read FOnURLClick write FOnURLClick;
property OnTextNotFound: TRichEditFindErrorEvent read FOnTextNotFound write FOnTextNotFound;
{$IFDEF RX_D3}
property OnCloseFindDialog: TRichEditFindCloseEvent read FOnCloseFindDialog
write FOnCloseFindDialog;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Clear; {$IFDEF RX_D3} override; {$ENDIF}
procedure SetSelection(StartPos, EndPos: Longint; ScrollCaret: Boolean);
function GetSelection: TCharRange;
function GetTextRange(StartPos, EndPos: Longint): string;
function LineFromChar(CharIndex: Integer): Integer;
function GetLineIndex(LineNo: Integer): Integer;
function GetLineLength(CharIndex: Integer): Integer;
function WordAtCursor: string;
function FindText(const SearchStr: string;
StartPos, Length: Integer; Options: TRichSearchTypes): Integer;
function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
{$IFDEF RX_D3} override; {$ENDIF}
function GetCaretPos: TPoint; {$IFDEF RX_V110} override; {$ENDIF}
function GetCharPos(CharIndex: Integer): TPoint;
function InsertObjectDialog: Boolean;
function ObjectPropertiesDialog: Boolean;
function PasteSpecialDialog: Boolean;
function FindDialog(const SearchStr: string): TFindDialog;
function ReplaceDialog(const SearchStr, ReplaceStr: string): TReplaceDialog;
function FindNext: Boolean;
procedure Print(const Caption: string); virtual;
class procedure RegisterConversionFormat(const AExtension: string;
APlainText: Boolean; AConversionClass: TConversionClass);
procedure ClearUndo;
procedure Redo;
procedure StopGroupTyping;
property CanFindNext: Boolean read GetCanFindNext;
property CanRedo: Boolean read GetCanRedo;
property CanPaste: Boolean read GetCanPaste;
{$IFNDEF RX_V110}
procedure Undo;
property CanUndo: Boolean read GetCanUndo;
property CaretPos: TPoint read GetCaretPos;
{$ENDIF}
property RedoName: TUndoName read GetRedoName;
property UndoName: TUndoName read GetUndoName;
property DefaultConverter: TConversionClass read FDefaultConverter
write FDefaultConverter;
property DefAttributes: TRxTextAttributes read FDefAttributes write SetDefAttributes;
property SelAttributes: TRxTextAttributes read FSelAttributes write SetSelAttributes;
property WordAttributes: TRxTextAttributes read FWordAttributes write SetWordAttributes;
property PageRect: TRect read FPageRect write FPageRect;
property Paragraph: TRxParaAttributes read FParagraph;
property SelectionType: TRichSelectionType read GetSelectionType;
end;
TRxRichEdit = class(TRxCustomRichEdit)
published
property Align;
property Alignment;
property AutoURLDetect;
property AutoVerbMenu;
property AllowObjects;
{$IFDEF RX_D3}
property AllowInPlace;
{$ENDIF}
{$IFDEF RX_D4}
property Anchors;
property BiDiMode;
property BorderWidth;
property DragKind;
{$ENDIF}
property BorderStyle;
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HideScrollBars;
property Title;
{$IFNDEF VER90}
property ImeMode;
property ImeName;
{$ENDIF}
{$IFDEF RX_D4}
property Constraints;
property ParentBiDiMode;
{$ENDIF}
property LangOptions;
property Lines;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PlainText;
property PopupMenu;
property ReadOnly;
property ScrollBars;
property SelectionBar;
property ShowHint;
property StreamFormat;
property StreamMode;
property TabOrder;
property TabStop;
property UndoLimit;
property Visible;
property WantTabs;
property WantReturns;
property WordSelection;
property WordWrap;
property OnChange;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
{$IFDEF RX_D5}
property OnContextPopup;
{$ENDIF}
{$IFDEF RX_D4}
property OnEndDock;
property OnStartDock;
{$ENDIF}
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{$IFDEF RX_D4}
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
{$ENDIF}
property OnProtectChange; { obsolete }
property OnProtectChangeEx;
property OnResizeRequest;
property OnSaveClipboard;
property OnSelectionChange;
property OnStartDrag;
property OnTextNotFound;
{$IFDEF RX_D3}
property OnCloseFindDialog;
{$ENDIF}
property OnURLClick;
end;
var
RichEditVersion: TRichEditVersion;
implementation
uses Printers, ComStrs, OleConst, OleDlg {$IFDEF RX_D3}, OleCtnrs {$ENDIF},
MaxMin;
const
RTFConversionFormat: TRichConversionFormat = (
ConversionClass: TConversion;
Extension: 'rtf';
PlainText: False;
Next: nil);
TextConversionFormat: TRichConversionFormat = (
ConversionClass: TConversion;
Extension: 'txt';
PlainText: True;
Next: @RTFConversionFormat);
var
ConversionFormatList: PRichConversionFormat = @TextConversionFormat;
const
RichEdit10ModuleName = 'RICHED32.DLL';
RichEdit20ModuleName = 'RICHED20.DLL';
{$IFNDEF RX_D3}
RICHEDIT_CLASSA = 'RichEdit20A'; { Richedit 2.0 Window Class }
RICHEDIT_CLASSW = 'RichEdit20W'; { Richedit 2.0 Unicode }
RICHEDIT_CLASS10A = 'RICHEDIT'; { Richedit 1.0 }
RICHEDIT_CLASS = RICHEDIT_CLASSA;
{$ENDIF}
{$IFNDEF RX_D3}
const
EM_SETUNDOLIMIT = WM_USER + 82;
EM_REDO = WM_USER + 84;
EM_CANREDO = WM_USER + 85;
EM_GETUNDONAME = WM_USER + 86;
EM_GETREDONAME = WM_USER + 87;
EM_STOPGROUPTYPING = WM_USER + 88;
EM_SETTEXTMODE = WM_USER + 89;
EM_GETTEXTMODE = WM_USER + 90;
{ for use with EM_GET/SETTEXTMODE }
TM_PLAINTEXT = 1;
TM_RICHTEXT = 2; { default behavior }
TM_SINGLELEVELUNDO = 4;
TM_MULTILEVELUNDO = 8; { default behavior }
TM_SINGLECODEPAGE = 16;
TM_MULTICODEPAGE = 32; { default behavior }
EM_AUTOURLDETECT = WM_USER + 91;
EM_GETAUTOURLDETECT = WM_USER + 92;
EM_SETPALETTE = WM_USER + 93;
EM_GETTEXTEX = WM_USER + 94;
EM_GETTEXTLENGTHEX = WM_USER + 95;
EM_SETLANGOPTIONS = WM_USER + 120;
EM_GETLANGOPTIONS = WM_USER + 121;
EM_GETIMECOMPMODE = WM_USER + 122;
{ Options for EM_SETLANGOPTIONS and EM_GETLANGOPTIONS }
IMF_AUTOKEYBOARD = $0001;
IMF_AUTOFONT = $0002;
IMF_IMECANCELCOMPLETE = $0004; { high completes the comp string when aborting, low cancels. }
IMF_IMEALWAYSSENDNOTIFY = $0008;
{ New notifications }
EN_OLEOPFAILED = $0709;
EN_OBJECTPOSITIONS = $070A;
EN_LINK = $070B;
EN_DRAGDROPDONE = $070C;
{ Event notification masks }
ENM_SCROLLEVENTS = $00000008;
ENM_DRAGDROPDONE = $00000010;
ENM_LANGCHANGE = $01000000;
ENM_OBJECTPOSITIONS = $02000000;
ENM_LINK = $04000000;
{ New edit control styles }
ES_NOOLEDRAGDROP = $00000008;
const
CFM_LINK = $00000020; { Exchange hyperlink extension }
CFM_EFFECTS = CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_COLOR or
CFM_STRIKEOUT or CFE_PROTECTED or CFM_LINK;
CFM_ALL = CFM_EFFECTS or CFM_SIZE or CFM_FACE or CFM_OFFSET or CFM_CHARSET;
PFM_ALL = PFM_STARTINDENT or PFM_RIGHTINDENT or PFM_OFFSET or
PFM_ALIGNMENT or PFM_TABSTOPS or PFM_NUMBERING or PFM_OFFSETINDENT;
{ New masks and effects -- a parenthesized asterisk indicates that
the data is stored by RichEdit2.0, but not displayed }
CFM_SMALLCAPS = $0040; { (*) }
CFM_ALLCAPS = $0080; { (*) }
CFM_HIDDEN = $0100; { (*) }
CFM_OUTLINE = $0200; { (*) }
CFM_SHADOW = $0400; { (*) }
CFM_EMBOSS = $0800; { (*) }
CFM_IMPRINT = $1000; { (*) }
CFM_DISABLED = $2000;
CFM_REVISED = $4000;
CFM_BACKCOLOR = $04000000;
CFM_LCID = $02000000;
CFM_UNDERLINETYPE = $00800000; { (*) }
CFM_WEIGHT = $00400000;
CFM_SPACING = $00200000; { (*) }
CFM_KERNING = $00100000; { (*) }
CFM_STYLE = $00080000; { (*) }
CFM_ANIMATION = $00040000; { (*) }
CFM_REVAUTHOR = $00008000;
CFE_LINK = $00000020;
CFE_AUTOCOLOR = $40000000; { NOTE: this corresponds to CFM_COLOR, }
{ which controls it }
CFE_SUBSCRIPT = $00010000; { Superscript and subscript are }
CFE_SUPERSCRIPT = $00020000; { mutually exclusive }
CFM_SUBSCRIPT = CFE_SUBSCRIPT or CFE_SUPERSCRIPT;
CFM_SUPERSCRIPT = CFM_SUBSCRIPT;
CFM_EFFECTS2 = CFM_EFFECTS or CFM_DISABLED or CFM_SMALLCAPS or CFM_ALLCAPS or
CFM_HIDDEN or CFM_OUTLINE or CFM_SHADOW or CFM_EMBOSS or
CFM_IMPRINT or CFM_DISABLED or CFM_REVISED or
CFM_SUBSCRIPT or CFM_SUPERSCRIPT or CFM_BACKCOLOR;
CFM_ALL2 = CFM_ALL or CFM_EFFECTS2 or CFM_BACKCOLOR or CFM_LCID or
CFM_UNDERLINETYPE or CFM_WEIGHT or CFM_REVAUTHOR or
CFM_SPACING or CFM_KERNING or CFM_STYLE or CFM_ANIMATION;
CFE_SMALLCAPS = CFM_SMALLCAPS;
CFE_ALLCAPS = CFM_ALLCAPS;
CFE_HIDDEN = CFM_HIDDEN;
CFE_OUTLINE = CFM_OUTLINE;
CFE_SHADOW = CFM_SHADOW;
CFE_EMBOSS = CFM_EMBOSS;
CFE_IMPRINT = CFM_IMPRINT;
CFE_DISABLED = CFM_DISABLED;
CFE_REVISED = CFM_REVISED;
CFE_AUTOBACKCOLOR = CFM_BACKCOLOR;
{ Underline types }
CFU_CF1UNDERLINE = $FF; { map charformat's bit underline to CF2. }
CFU_INVERT = $FE; { For IME composition fake a selection. }
CFU_UNDERLINEDOTTED = $4; { (*) displayed as ordinary underline }
CFU_UNDERLINEDOUBLE = $3; { (*) displayed as ordinary underline }
CFU_UNDERLINEWORD = $2; { (*) displayed as ordinary underline }
CFU_UNDERLINE = $1;
CFU_UNDERLINENONE = 0;
{ PARAFORMAT 2.0 masks and effects }
const
PFM_SPACEBEFORE = $00000040;
PFM_SPACEAFTER = $00000080;
PFM_LINESPACING = $00000100;
PFM_STYLE = $00000400;
PFM_BORDER = $00000800; { (*) }
PFM_SHADING = $00001000; { (*) }
PFM_NUMBERINGSTYLE = $00002000; { (*) }
PFM_NUMBERINGTAB = $00004000; { (*) }
PFM_NUMBERINGSTART = $00008000; { (*) }
PFM_RTLPARA = $00010000;
PFM_KEEP = $00020000; { (*) }
PFM_KEEPNEXT = $00040000; { (*) }
PFM_PAGEBREAKBEFORE = $00080000; { (*) }
PFM_NOLINENUMBER = $00100000; { (*) }
PFM_NOWIDOWCONTROL = $00200000; { (*) }
PFM_DONOTHYPHEN = $00400000; { (*) }
PFM_SIDEBYSIDE = $00800000; { (*) }
PFM_TABLE = $C0000000; { (*) }
{ Note: PARAFORMAT has no effects }
PFM_EFFECTS = PFM_RTLPARA or PFM_KEEP or PFM_KEEPNEXT or PFM_TABLE or
PFM_PAGEBREAKBEFORE or PFM_NOLINENUMBER or
PFM_NOWIDOWCONTROL or PFM_DONOTHYPHEN or PFM_SIDEBYSIDE or PFM_TABLE;
PFM_ALL2 = PFM_ALL or PFM_EFFECTS or PFM_SPACEBEFORE or PFM_SPACEAFTER or
PFM_LINESPACING or PFM_STYLE or PFM_SHADING or PFM_BORDER or
PFM_NUMBERINGTAB or PFM_NUMBERINGSTART or PFM_NUMBERINGSTYLE;
PFE_RTLPARA = PFM_RTLPARA shr 16;
PFE_KEEP = PFM_KEEP shr 16; { (*) }
PFE_KEEPNEXT = PFM_KEEPNEXT shr 16; { (*) }
PFE_PAGEBREAKBEFORE = PFM_PAGEBREAKBEFORE shr 16; { (*) }
PFE_NOLINENUMBER = PFM_NOLINENUMBER shr 16; { (*) }
PFE_NOWIDOWCONTROL = PFM_NOWIDOWCONTROL shr 16; { (*) }
PFE_DONOTHYPHEN = PFM_DONOTHYPHEN shr 16; { (*) }
PFE_SIDEBYSIDE = PFM_SIDEBYSIDE shr 16; { (*) }
PFE_TABLEROW = $C000; { These 3 options are mutually }
PFE_TABLECELLEND = $8000; { exclusive and each imply }
PFE_TABLECELL = $4000; { that para is part of a table }
PFA_JUSTIFY = 4; { New paragraph-alignment option 2.0 (*) }
const
SF_UNICODE = $0010; { Unicode file of some kind }
type
TFindTextExA = record
chrg: TCharRange;
lpstrText: PAnsiChar;
chrgText: TCharRange;
end;
TObjectPositions = packed record
nmhdr: TNMHdr;
cObjectCount: Longint;
pcpPositions: PLongint;
end;
TENLink = record
nmhdr: TNMHdr;
msg: UINT;
wParam: WPARAM;
lParam: LPARAM;
chrg: TCharRange;
end;
TENOleOpFailed = packed record
nmhdr: TNMHdr;
iob: Longint;
lOper: Longint;
hr: HRESULT;
end;
{ flags for the GETTEXTLENGTHEX data structure }
const
GTL_DEFAULT = 0; { do the default (return # of chars) }
GTL_USECRLF = 1; { compute answer using CRLFs for paragraphs }
GTL_PRECISE = 2; { compute a precise answer }
GTL_CLOSE = 4; { fast computation of a "close" answer }
GTL_NUMCHARS = 8; { return the number of characters }
GTL_NUMBYTES = 16; { return the number of _bytes_ }
{ EM_GETTEXTLENGTHEX info; this struct is passed in the wparam of the msg }
type
TGetTextLengthEx = record
flags: DWORD; { flags (see GTL_XXX defines) }
codepage: UINT; { code page for translation }
end;
const
OLEOP_DOVERB = 1;
{$ENDIF RX_D3}
const
FT_DOWN = 1;
type
PENLink = ^TENLink;
PENOleOpFailed = ^TENOleOpFailed;
TFindTextEx = TFindTextExA;
TTextRangeA = record
chrg: TCharRange;
lpstrText: PAnsiChar;
end;
TTextRangeW = record
chrg: TCharRange;
lpstrText: PWideChar;
end;
TTextRange = TTextRangeA;
{$IFDEF RX_D3}
function ResStr(const Ident: string): string;
begin
Result := Ident;
end;
{$ELSE}
function ResStr(Ident: Cardinal): string;
begin
Result := LoadStr(Ident);
end;
{$ENDIF}
{ TRxTextAttributes }
const
AttrFlags: array[TRxAttributeType] of Word = (0, SCF_SELECTION,
SCF_WORD or SCF_SELECTION);
constructor TRxTextAttributes.Create(AOwner: TRxCustomRichEdit;
AttributeType: TRxAttributeType);
begin
inherited Create;
RichEdit := AOwner;
FType := AttributeType;
end;
procedure TRxTextAttributes.InitFormat(var Format: TCharFormat2);
begin
FillChar(Format, SizeOf(Format), 0);
if RichEditVersion >= 2 then Format.cbSize := SizeOf(Format)
else Format.cbSize := SizeOf(TCharFormat);
end;
function TRxTextAttributes.GetConsistentAttributes: TRxConsistentAttributes;
var
Format: TCharFormat2;
begin
Result := [];
if RichEdit.HandleAllocated and (FType <> atDefaultText) then begin
InitFormat(Format);
SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
AttrFlags[FType], 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_OFFSET) <> 0 then Include(Result, caOffset);
if (dwMask and CFM_HIDDEN) <> 0 then Include(result, caHidden);
if RichEditVersion >= 2 then begin
if (dwMask and CFM_LINK) <> 0 then Include(Result, caLink);
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, caSubscript);
if (dwMask and CFM_REVAUTHOR) <> 0 then Include(Result, caRevAuthor);
end;
end;
end;
end;
procedure TRxTextAttributes.GetAttributes(var Format: TCharFormat2);
begin
InitFormat(Format);
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_GETCHARFORMAT, AttrFlags[FType],
LPARAM(@Format));
end;
procedure TRxTextAttributes.SetAttributes(var Format: TCharFormat2);
begin
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, AttrFlags[FType],
LPARAM(@Format));
end;
{$IFNDEF VER90}
function TRxTextAttributes.GetCharset: TFontCharset;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.bCharset;
end;
procedure TRxTextAttributes.SetCharset(Value: TFontCharset);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_CHARSET;
bCharSet := Value;
end;
SetAttributes(Format);
end;
{$ENDIF}
function TRxTextAttributes.GetProtected: Boolean;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
with Format do
Result := (dwEffects and CFE_PROTECTED) <> 0;
end;
procedure TRxTextAttributes.SetProtected(Value: Boolean);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := CFM_PROTECTED;
if Value then dwEffects := CFE_PROTECTED;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetLink: Boolean;
var
Format: TCharFormat2;
begin
Result := False;
if RichEditVersion < 2 then Exit;
GetAttributes(Format);
with Format do Result := (dwEffects and CFE_LINK) <> 0;
end;
procedure TRxTextAttributes.SetLink(Value: Boolean);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_LINK;
if Value then dwEffects := CFE_LINK;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetRevAuthorIndex: Byte;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.bRevAuthor;
end;
procedure TRxTextAttributes.SetRevAuthorIndex(Value: Byte);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_REVAUTHOR;
bRevAuthor := Value;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetHidden: Boolean;
var
Format: TCharFormat2;
begin
Result := False;
if RichEditVersion < 2 then Exit;
GetAttributes(Format);
Result := Format.dwEffects and CFE_HIDDEN <> 0;
end;
procedure TRxTextAttributes.SetHidden(Value: Boolean);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_HIDDEN;
if Value then dwEffects := CFE_HIDDEN;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetDisabled: Boolean;
var
Format: TCharFormat2;
begin
Result := False;
if RichEditVersion < 2 then Exit;
GetAttributes(Format);
Result := Format.dwEffects and CFE_DISABLED <> 0;
end;
procedure TRxTextAttributes.SetDisabled(Value: Boolean);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_DISABLED;
if Value then dwEffects := CFE_DISABLED;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.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 TRxTextAttributes.SetColor(Value: TColor);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := CFM_COLOR;
if (Value = clWindowText) or (Value = clDefault) then
dwEffects := CFE_AUTOCOLOR
else crTextColor := ColorToRGB(Value);
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetBackColor: TColor;
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then begin
Result := clWindow;
Exit;
end;
GetAttributes(Format);
with Format do
if (dwEffects and CFE_AUTOBACKCOLOR) <> 0 then Result := clWindow
else Result := crBackColor;
end;
procedure TRxTextAttributes.SetBackColor(Value: TColor);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_BACKCOLOR;
if (Value = clWindow) or (Value = clDefault) then
dwEffects := CFE_AUTOBACKCOLOR
else crBackColor := ColorToRGB(Value);
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetName: TFontName;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.szFaceName;
end;
procedure TRxTextAttributes.SetName(Value: TFontName);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := CFM_FACE;
StrPLCopy(szFaceName, Value, SizeOf(szFaceName));
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetStyle: TFontStyles;
var
Format: TCharFormat2;
begin
Result := [];
GetAttributes(Format);
with Format do begin
if (dwEffects and CFE_BOLD) <> 0 then Include(Result, fsBold);
if (dwEffects and CFE_ITALIC) <> 0 then Include(Result, fsItalic);
if (dwEffects and CFE_UNDERLINE) <> 0 then Include(Result, fsUnderline);
if (dwEffects and CFE_STRIKEOUT) <> 0 then Include(Result, fsStrikeOut);
end;
end;
procedure TRxTextAttributes.SetStyle(Value: TFontStyles);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT;
if fsBold in Value then dwEffects := dwEffects or CFE_BOLD;
if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC;
if fsUnderline in Value then dwEffects := dwEffects or CFE_UNDERLINE;
if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetUnderlineType: TUnderlineType;
var
Format: TCharFormat2;
begin
Result := utNone;
if RichEditVersion < 2 then Exit;
GetAttributes(Format);
with Format do begin
if (dwEffects and CFE_UNDERLINE <> 0) and
(dwMask and CFM_UNDERLINETYPE = CFM_UNDERLINETYPE) then
Result := TUnderlineType(bUnderlineType);
end;
end;
procedure TRxTextAttributes.SetUnderlineType(Value: TUnderlineType);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := CFM_UNDERLINETYPE or CFM_UNDERLINE;
bUnderlineType := Ord(Value);
if Value <> utNone then dwEffects := dwEffects or CFE_UNDERLINE;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetOffset: Integer;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.yOffset div 20;
end;
procedure TRxTextAttributes.SetOffset(Value: Integer);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := DWORD(CFM_OFFSET);
yOffset := Value * 20;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetSize: Integer;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.yHeight div 20;
end;
procedure TRxTextAttributes.SetSize(Value: Integer);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
dwMask := DWORD(CFM_SIZE);
yHeight := Value * 20;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetHeight: Integer;
begin
Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
end;
procedure TRxTextAttributes.SetHeight(Value: Integer);
begin
Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
end;
function TRxTextAttributes.GetPitch: TFontPitch;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
case (Format.bPitchAndFamily and $03) of
DEFAULT_PITCH: Result := fpDefault;
VARIABLE_PITCH: Result := fpVariable;
FIXED_PITCH: Result := fpFixed;
else Result := fpDefault;
end;
end;
procedure TRxTextAttributes.SetPitch(Value: TFontPitch);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
case Value of
fpVariable: bPitchAndFamily := VARIABLE_PITCH;
fpFixed: bPitchAndFamily := FIXED_PITCH;
else bPitchAndFamily := DEFAULT_PITCH;
end;
end;
SetAttributes(Format);
end;
function TRxTextAttributes.GetSubscriptStyle: TSubscriptStyle;
var
Format: TCharFormat2;
begin
Result := ssNone;
if RichEditVersion < 2 then Exit;
GetAttributes(Format);
with Format do begin
if (dwEffects and CFE_SUBSCRIPT) <> 0 then
Result := ssSubscript
else if (dwEffects and CFE_SUPERSCRIPT) <> 0 then
Result := ssSuperscript;
end;
end;
procedure TRxTextAttributes.SetSubscriptStyle(Value: TSubscriptStyle);
var
Format: TCharFormat2;
begin
if RichEditVersion < 2 then Exit;
InitFormat(Format);
with Format do begin
dwMask := DWORD(CFM_SUBSCRIPT);
case Value of
ssSubscript: dwEffects := CFE_SUBSCRIPT;
ssSuperscript: dwEffects := CFE_SUPERSCRIPT;
end;
end;
SetAttributes(Format);
end;
procedure TRxTextAttributes.AssignFont(Font: TFont);
var
LogFont: TLogFont;
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do begin
case Font.Pitch of
fpVariable: bPitchAndFamily := VARIABLE_PITCH;
fpFixed: bPitchAndFamily := FIXED_PITCH;
else bPitchAndFamily := DEFAULT_PITCH;
end;
dwMask := dwMask or CFM_SIZE or CFM_BOLD or CFM_ITALIC or
CFM_UNDERLINE or CFM_STRIKEOUT or CFM_FACE or CFM_COLOR;
yHeight := Font.Size * 20;
if fsBold in Font.Style then dwEffects := dwEffects or CFE_BOLD;
if fsItalic in Font.Style then dwEffects := dwEffects or CFE_ITALIC;
if fsUnderline in Font.Style then dwEffects := dwEffects or CFE_UNDERLINE;
if fsStrikeOut in Font.Style then dwEffects := dwEffects or CFE_STRIKEOUT;
StrPLCopy(szFaceName, Font.Name, SizeOf(szFaceName));
if (Font.Color = clWindowText) or (Font.Color = clDefault) then
dwEffects := CFE_AUTOCOLOR
else crTextColor := ColorToRGB(Font.Color);
{$IFNDEF VER90}
dwMask := dwMask or CFM_CHARSET;
bCharSet := Font.Charset;
{$ENDIF}
if GetObject(Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then begin
dwMask := dwMask or DWORD(CFM_WEIGHT);
wWeight := Word(LogFont.lfWeight);
end;
end;
SetAttributes(Format);
end;
procedure TRxTextAttributes.Assign(Source: TPersistent);
var
Format: TCharFormat2;
begin
if Source is TFont then AssignFont(TFont(Source))
else if Source is TTextAttributes then begin
Name := TTextAttributes(Source).Name;
{$IFDEF RX_D3}
Charset := TTextAttributes(Source).Charset;
{$ENDIF}
Style := TTextAttributes(Source).Style;
Pitch := TTextAttributes(Source).Pitch;
Color := TTextAttributes(Source).Color;
end
else if Source is TRxTextAttributes then begin
TRxTextAttributes(Source).GetAttributes(Format);
SetAttributes(Format);
end
else inherited Assign(Source);
end;
procedure TRxTextAttributes.AssignTo(Dest: TPersistent);
begin
if Dest is TFont then begin
TFont(Dest).Color := Color;
TFont(Dest).Name := Name;
{$IFNDEF VER90}
TFont(Dest).Charset := Charset;
{$ENDIF}
TFont(Dest).Style := Style;
TFont(Dest).Size := Size;
TFont(Dest).Pitch := Pitch;
end
else if Dest is TTextAttributes then begin
TTextAttributes(Dest).Color := Color;
TTextAttributes(Dest).Name := Name;
{$IFDEF RX_D3}
TTextAttributes(Dest).Charset := Charset;
{$ENDIF}
TTextAttributes(Dest).Style := Style;
TTextAttributes(Dest).Pitch := Pitch;
end
else inherited AssignTo(Dest);
end;
{ TRxParaAttributes }
constructor TRxParaAttributes.Create(AOwner: TRxCustomRichEdit);
begin
inherited Create;
RichEdit := AOwner;
end;
procedure TRxParaAttributes.InitPara(var Paragraph: TParaFormat2);
begin
FillChar(Paragraph, SizeOf(Paragraph), 0);
if RichEditVersion >= 2 then
Paragraph.cbSize := SizeOf(Paragraph)
else
Paragraph.cbSize := SizeOf(TParaFormat);
end;
procedure TRxParaAttributes.GetAttributes(var Paragraph: TParaFormat2);
begin
InitPara(Paragraph);
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
end;
procedure TRxParaAttributes.SetAttributes(var Paragraph: TParaFormat2);
begin
{$IFDEF RX_D4}
RichEdit.HandleNeeded; { we REALLY need the handle for BiDi }
{$ENDIF}
if RichEdit.HandleAllocated then begin
{$IFDEF RX_D4}
if RichEdit.UseRightToLeftAlignment then
if Paragraph.wAlignment = PFA_LEFT then
Paragraph.wAlignment := PFA_RIGHT
else if Paragraph.wAlignment = PFA_RIGHT then
Paragraph.wAlignment := PFA_LEFT;
{$ENDIF}
SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph));
end;
end;
function TRxParaAttributes.GetAlignment: TParaAlignment;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := TParaAlignment(Paragraph.wAlignment - 1);
end;
procedure TRxParaAttributes.SetAlignment(Value: TParaAlignment);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_ALIGNMENT;
wAlignment := Ord(Value) + 1;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetNumbering: TRxNumbering;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := TRxNumbering(Paragraph.wNumbering);
if RichEditVersion = 1 then
if Result <> nsNone then Result := nsBullet;
end;
procedure TRxParaAttributes.SetNumbering(Value: TRxNumbering);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion = 1 then
if Value <> nsNone then Value := TRxNumbering(PFN_BULLET);
case Value of
nsNone: LeftIndent := 0;
else if LeftIndent < 10 then LeftIndent := 10;
end;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_NUMBERING;
wNumbering := Ord(Value);
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetNumberingStyle: TRxNumberingStyle;
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then
Result := nsSimple
else begin
GetAttributes(Paragraph);
Result := TRxNumberingStyle(Paragraph.wNumberingStyle);
end;
end;
procedure TRxParaAttributes.SetNumberingStyle(Value: TRxNumberingStyle);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_NUMBERINGSTYLE;
wNumberingStyle := Ord(Value);
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetNumberingTab: Word;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.wNumberingTab div 20;
end;
procedure TRxParaAttributes.SetNumberingTab(Value: Word);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_NUMBERINGTAB;
wNumberingTab := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetFirstIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxStartIndent div 20;
end;
procedure TRxParaAttributes.SetFirstIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_STARTINDENT;
dxStartIndent := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetHeadingStyle: THeadingStyle;
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 3 then Result := 0
else begin
GetAttributes(Paragraph);
Result := Paragraph.sStyle;
end;
end;
procedure TRxParaAttributes.SetHeadingStyle(Value: THeadingStyle);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 3 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_STYLE;
sStyle := Value;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetLeftIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxOffset div 20;
end;
procedure TRxParaAttributes.SetLeftIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_OFFSET;
dxOffset := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetRightIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxRightIndent div 20;
end;
procedure TRxParaAttributes.SetRightIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_RIGHTINDENT;
dxRightIndent := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetSpaceAfter: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dySpaceAfter div 20;
end;
procedure TRxParaAttributes.SetSpaceAfter(Value: Longint);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_SPACEAFTER;
dySpaceAfter := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetSpaceBefore: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dySpaceBefore div 20;
end;
procedure TRxParaAttributes.SetSpaceBefore(Value: Longint);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_SPACEBEFORE;
dySpaceBefore := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetLineSpacing: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dyLineSpacing div 20;
end;
procedure TRxParaAttributes.SetLineSpacing(Value: Longint);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
GetAttributes(Paragraph);
with Paragraph do begin
dwMask := PFM_LINESPACING;
dyLineSpacing := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetLineSpacingRule: TLineSpacingRule;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := TLineSpacingRule(Paragraph.bLineSpacingRule);
end;
procedure TRxParaAttributes.SetLineSpacingRule(Value: TLineSpacingRule);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
GetAttributes(Paragraph);
with Paragraph do begin
dwMask := PFM_LINESPACING;
bLineSpacingRule := Ord(Value);
end;
SetAttributes(Paragraph);
end;
function TRxParaAttributes.GetTab(Index: Byte): Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.rgxTabs[Index] div 20;
end;
procedure TRxParaAttributes.SetTab(Index: Byte; Value: Longint);
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
with Paragraph do
begin
rgxTabs[Index] := Value * 20;
dwMask := PFM_TABSTOPS;
if cTabCount < Index then cTabCount := Index;
SetAttributes(Paragraph);
end;
end;
function TRxParaAttributes.GetTabCount: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.cTabCount;
end;
procedure TRxParaAttributes.SetTabCount(Value: Integer);
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
with Paragraph do
begin
dwMask := PFM_TABSTOPS;
cTabCount := Value;
SetAttributes(Paragraph);
end;
end;
function TRxParaAttributes.GetTableStyle: TParaTableStyle;
var
Paragraph: TParaFormat2;
begin
Result := tsNone;
if RichEditVersion < 2 then Exit;
GetAttributes(Paragraph);
with Paragraph do begin
if (wReserved and PFE_TABLEROW) <> 0 then
Result := tsTableRow
else if (wReserved and PFE_TABLECELLEND) <> 0 then
Result := tsTableCellEnd
else if (wReserved and PFE_TABLECELL) <> 0 then
Result := tsTableCell;
end;
end;
procedure TRxParaAttributes.SetTableStyle(Value: TParaTableStyle);
var
Paragraph: TParaFormat2;
begin
if RichEditVersion < 2 then Exit;
InitPara(Paragraph);
with Paragraph do begin
dwMask := PFM_TABLE;
case Value of
tsTableRow: wReserved := PFE_TABLEROW;
tsTableCellEnd: wReserved := PFE_TABLECELLEND;
tsTableCell: wReserved := PFE_TABLECELL;
end;
end;
SetAttributes(Paragraph);
end;
procedure TRxParaAttributes.AssignTo(Dest: TPersistent);
var
I: Integer;
begin
if Dest is TParaAttributes then begin
with TParaAttributes(Dest) do begin
if Self.Alignment = paJustify then Alignment := taLeftJustify
else Alignment := TAlignment(Self.Alignment);
FirstIndent := Self.FirstIndent;
LeftIndent := Self.LeftIndent;
RightIndent := Self.RightIndent;
if Self.Numbering <> nsNone then
Numbering := TNumberingStyle(nsBullet)
else Numbering := TNumberingStyle(nsNone);
for I := 0 to MAX_TAB_STOPS - 1 do
Tab[I] := Self.Tab[I];
end;
end
else inherited AssignTo(Dest);
end;
procedure TRxParaAttributes.Assign(Source: TPersistent);
var
I: Integer;
Paragraph: TParaFormat2;
begin
if Source is TParaAttributes then begin
Alignment := TParaAlignment(TParaAttributes(Source).Alignment);
FirstIndent := TParaAttributes(Source).FirstIndent;
LeftIndent := TParaAttributes(Source).LeftIndent;
RightIndent := TParaAttributes(Source).RightIndent;
Numbering := TRxNumbering(TParaAttributes(Source).Numbering);
for I := 0 to MAX_TAB_STOPS - 1 do
Tab[I] := TParaAttributes(Source).Tab[I];
end
else if Source is TRxParaAttributes then begin
TRxParaAttributes(Source).GetAttributes(Paragraph);
SetAttributes(Paragraph);
end
else inherited Assign(Source);
end;
{ OLE utility routines }
function WStrLen(Str: PWideChar): Integer;
begin
Result := 0;
while Str[Result] <> #0 do Inc(Result);
end;
procedure ReleaseObject(var Obj);
begin
if IUnknown(Obj) <> nil then begin
{$IFNDEF RX_D3}
IUnknown(Obj).Release;
{$ENDIF}
IUnknown(Obj) := nil;
end;
end;
procedure CreateStorage(var Storage: IStorage);
var
LockBytes: ILockBytes;
begin
OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
try
OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE
or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Storage));
finally
ReleaseObject(LockBytes);
end;
end;
procedure DestroyMetaPict(MetaPict: HGlobal);
begin
if MetaPict <> 0 then begin
DeleteMetaFile(PMetaFilePict(GlobalLock(MetaPict))^.hMF);
GlobalUnlock(MetaPict);
GlobalFree(MetaPict);
end;
end;
function OleSetDrawAspect(OleObject: IOleObject; Iconic: Boolean;
IconMetaPict: HGlobal; var DrawAspect: Longint): HResult;
var
OleCache: IOleCache;
EnumStatData: IEnumStatData;
OldAspect, AdviseFlags, Connection: Longint;
TempMetaPict: HGlobal;
FormatEtc: TFormatEtc;
Medium: TStgMedium;
ClassID: TCLSID;
StatData: TStatData;
begin
Result := S_OK;
OldAspect := DrawAspect;
if Iconic then begin
DrawAspect := DVASPECT_ICON;
AdviseFlags := ADVF_NODATA;
end
else begin
DrawAspect := DVASPECT_CONTENT;
AdviseFlags := ADVF_PRIMEFIRST;
end;
if (DrawAspect <> OldAspect) or (DrawAspect = DVASPECT_ICON) then begin
{$IFDEF RX_D3}
Result := OleObject.QueryInterface(IOleCache, OleCache);
{$ELSE}
Result := OleObject.QueryInterface(IID_IOleCache, OleCache);
{$ENDIF}
if Succeeded(Result) then
try
if DrawAspect <> OldAspect then begin
{ Setup new cache with the new aspect }
FillChar(FormatEtc, SizeOf(FormatEtc), 0);
FormatEtc.dwAspect := DrawAspect;
FormatEtc.lIndex := -1;
Result := OleCache.Cache(FormatEtc, AdviseFlags, Connection);
end;
if Succeeded(Result) and (DrawAspect = DVASPECT_ICON) then begin
TempMetaPict := 0;
if IconMetaPict = 0 then begin
if Succeeded(OleObject.GetUserClassID(ClassID)) then begin
TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
IconMetaPict := TempMetaPict;
end;
end;
try
FormatEtc.cfFormat := CF_METAFILEPICT;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_ICON;
FormatEtc.lIndex := -1;
FormatEtc.tymed := TYMED_MFPICT;
Medium.tymed := TYMED_MFPICT;
Medium.hMetaFilePict := IconMetaPict;
Medium.unkForRelease := nil;
Result := OleCache.SetData(FormatEtc, Medium, False);
finally
DestroyMetaPict(TempMetaPict);
end;
end;
if Succeeded(Result) and (DrawAspect <> OldAspect) then begin
{ remove any existing caches that are set up for the old display aspect }
OleCache.EnumCache(EnumStatData);
if EnumStatData <> nil then
try
while EnumStatData.Next(1, StatData, nil) = 0 do
if StatData.formatetc.dwAspect = OldAspect then
OleCache.Uncache(StatData.dwConnection);
finally
ReleaseObject(EnumStatData);
end;
end;
finally
ReleaseObject(OleCache);
end;
if Succeeded(Result) and (DrawAspect <> DVASPECT_ICON) then
OleObject.Update;
end;
end;
function GetIconMetaPict(OleObject: IOleObject; DrawAspect: Longint): HGlobal;
var
DataObject: IDataObject;
FormatEtc: TFormatEtc;
Medium: TStgMedium;
ClassID: TCLSID;
begin
Result := 0;
if DrawAspect = DVASPECT_ICON then begin
{$IFDEF RX_D3}
OleObject.QueryInterface(IDataObject, DataObject);
{$ELSE}
OleObject.QueryInterface(IID_IDataObject, DataObject);
{$ENDIF}
if DataObject <> nil then begin
FormatEtc.cfFormat := CF_METAFILEPICT;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_ICON;
FormatEtc.lIndex := -1;
FormatEtc.tymed := TYMED_MFPICT;
if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
Result := Medium.hMetaFilePict;
ReleaseObject(DataObject);
end;
end;
if Result = 0 then begin
OleCheck(OleObject.GetUserClassID(ClassID));
Result := OleGetIconOfClass(ClassID, nil, True);
end;
end;
{ Return the first piece of a moniker }
function OleStdGetFirstMoniker(Moniker: IMoniker): IMoniker;
var
Mksys: Longint;
EnumMoniker: IEnumMoniker;
begin
Result := nil;
if Moniker <> nil then begin
if (Moniker.IsSystemMoniker(Mksys) = 0) and
(Mksys = MKSYS_GENERICCOMPOSITE) then
begin
if Moniker.Enum(True, EnumMoniker) <> 0 then Exit;
EnumMoniker.Next(1, Result, nil);
ReleaseObject(EnumMoniker);
end
else begin
{$IFNDEF RX_D3}
Moniker.AddRef;
{$ENDIF}
Result := Moniker;
end;
end;
end;
{ Return length of file moniker piece of the given moniker }
function OleStdGetLenFilePrefixOfMoniker(Moniker: IMoniker): Integer;
var
MkFirst: IMoniker;
BindCtx: IBindCtx;
Mksys: Longint;
P: PWideChar;
begin
Result := 0;
if Moniker <> nil then begin
MkFirst := OleStdGetFirstMoniker(Moniker);
if MkFirst <> nil then begin
if (MkFirst.IsSystemMoniker(Mksys) = 0) and
(Mksys = MKSYS_FILEMONIKER) then
begin
if CreateBindCtx(0, BindCtx) = 0 then begin
if (MkFirst.GetDisplayName(BindCtx, nil, P) = 0) and (P <> nil) then
begin
Result := WStrLen(P);
CoTaskMemFree(P);
end;
ReleaseObject(BindCtx);
end;
end;
ReleaseObject(MkFirst);
end;
end;
end;
function CoAllocCStr(const S: string): PChar;
begin
Result := StrCopy(CoTaskMemAlloc(Length(S) + 1), PChar(S));
end;
function WStrToString(P: PWideChar): string;
begin
Result := '';
if P <> nil then begin
Result := WideCharToString(P);
CoTaskMemFree(P);
end;
end;
function GetFullNameStr(OleObject: IOleObject): string;
var
P: PWideChar;
begin
OleObject.GetUserType(USERCLASSTYPE_FULL, P);
Result := WStrToString(P);
end;
function GetShortNameStr(OleObject: IOleObject): string;
var
P: PWideChar;
begin
OleObject.GetUserType(USERCLASSTYPE_SHORT, P);
Result := WStrToString(P);
end;
function GetDisplayNameStr(OleLink: IOleLink): string;
var
P: PWideChar;
begin
OleLink.GetSourceDisplayName(P);
Result := WStrToString(P);
end;
{$IFDEF RX_D3}
function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
begin
if Form.OleFormObject = nil then TOleForm.Create(Form);
Result := Form.OleFormObject as IVCLFrameForm;
end;
function IsFormMDIChild(Form: TCustomForm): Boolean;
begin
Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild);
end;
{$ENDIF}
{ Clipboard formats }
var
CFEmbeddedObject: Integer;
CFLinkSource: Integer;
CFRtf: Integer;
CFRtfNoObjs: Integer;
const
{$IFNDEF RX_D3}
CF_RTFNOOBJS = 'Rich Text Format Without Objects';
{$ENDIF}
CF_EMBEDDEDOBJECT = 'Embedded Object';
CF_LINKSOURCE = 'Link Source';
{************************************************************************}
{ OLE Extensions to the Rich Text Editor }
{ Converted from RICHOLE.H }
{ Structure passed to GetObject and InsertObject }
type
_ReObject = record
cbStruct: DWORD; { Size of structure }
cp: ULONG; { Character position of object }
clsid: TCLSID; { Class ID of object }
poleobj: IOleObject; { OLE object interface }
pstg: IStorage; { Associated storage interface }
polesite: IOleClientSite; { Associated client site interface }
sizel: TSize; { Size of object (may be 0,0) }
dvAspect: Longint; { Display aspect to use }
dwFlags: DWORD; { Object status flags }
dwUser: DWORD; { Dword for user's use }
end;
TReObject = _ReObject;
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 }
{ RichEdit GUIDs }
IID_IRichEditOle: TGUID = (
D1:$00020D00;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
IID_IRichEditOleCallback: TGUID = (
D1:$00020D03;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
type
{
* IRichEditOle
*
* Purpose:
* Interface used by the client of RichEdit to perform OLE-related
* operations.
*
* The methods herein may just want to be regular Windows messages.
}
{$IFDEF RX_D3}
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: TIID;
lpstrUserTypeNew: LPCSTR): HResult; stdcall;
function ActivateAs(rclsid: TIID; rclsidAs: TIID): 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;
{$ELSE}
IRichEditOle = class(IUnknown)
function GetClientSite(var clientSite: IOleClientSite): HResult; virtual; stdcall; abstract;
function GetObjectCount: HResult; virtual; stdcall; abstract;
function GetLinkCount: HResult; virtual; stdcall; abstract;
function GetObject(iob: Longint; var reobject: TReObject;
dwFlags: DWORD): HResult; virtual; stdcall; abstract;
function InsertObject(var reobject: TReObject): HResult; virtual; stdcall; abstract;
function ConvertObject(iob: Longint; rclsidNew: TIID;
lpstrUserTypeNew: LPCSTR): HResult; virtual; stdcall; abstract;
function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; virtual; stdcall; abstract;
function SetHostNames(lpstrContainerApp: LPCSTR;
lpstrContainerObj: LPCSTR): HResult; virtual; stdcall; abstract;
function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; virtual; stdcall; abstract;
function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; virtual; stdcall; abstract;
function HandsOffStorage(iob: Longint): HResult; virtual; stdcall; abstract;
function SaveCompleted(iob: Longint; const stg: IStorage): HResult; virtual; stdcall; abstract;
function InPlaceDeactivate: HResult; virtual; stdcall; abstract;
function ContextSensitiveHelp(fEnterMode: BOOL): HResult; virtual; stdcall; abstract;
function GetClipboardData(var chrg: TCharRange; reco: DWORD;
var dataobj: IDataObject): HResult; virtual; stdcall; abstract;
function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
hMetaPict: HGLOBAL): HResult; virtual; stdcall; abstract;
end;
{$ENDIF}
{
* IRichEditOleCallback
*
* Purpose:
* Interface used by the RichEdit to get OLE-related stuff from the
* application using RichEdit.
}
{$IFDEF RX_D3}
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;
{$ELSE}
IRichEditOleCallback = class(IUnknown)
function GetNewStorage(var stg: IStorage): HResult; virtual; stdcall; abstract;
function GetInPlaceContext(var Frame: IOleInPlaceFrame;
var Doc: IOleInPlaceUIWindow;
lpFrameInfo: POleInPlaceFrameInfo): HResult; virtual; stdcall; abstract;
function ShowContainerUI(fShow: BOOL): HResult; virtual; stdcall; abstract;
function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
cp: Longint): HResult; virtual; stdcall; abstract;
function DeleteObject(const oleobj: IOleObject): HResult; virtual; stdcall; abstract;
function QueryAcceptData(const dataobj: IDataObject;
var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
hMetaPict: HGLOBAL): HResult; virtual; stdcall; abstract;
function ContextSensitiveHelp(fEnterMode: BOOL): HResult; virtual; stdcall; abstract;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
var dataobj: IDataObject): HResult; virtual; stdcall; abstract;
function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
var dwEffect: DWORD): HResult; virtual; stdcall; abstract;
function GetContextMenu(seltype: Word; const oleobj: IOleObject;
const chrg: TCharRange; var menu: HMENU): HResult; virtual; stdcall; abstract;
end;
{$ENDIF}
{************************************************************************}
{ TRichEditOleCallback }
type
{$IFDEF RX_D3}
TRichEditOleCallback = class(TObject, IUnknown, IRichEditOleCallback)
private
FDocForm: IVCLFrameForm;
FFrameForm: IVCLFrameForm;
FAccelTable: HAccel;
FAccelCount: Integer;
{$IFDEF RX_D4}
FAutoScroll: Boolean;
{$ENDIF}
procedure CreateAccelTable;
procedure DestroyAccelTable;
procedure AssignFrame;
{$ELSE}
TRichEditOleCallback = class(IRichEditOleCallback)
{$ENDIF}
private
FRefCount: Longint;
FRichEdit: TRxCustomRichEdit;
public
constructor Create(RichEdit: TRxCustomRichEdit);
destructor Destroy; override;
{$IFDEF RX_D3}
function QueryInterface(const iid: TGUID; out Obj): HResult; stdcall;
function _AddRef: Longint; stdcall;
function _Release: Longint; stdcall;
function GetNewStorage(out stg: IStorage): HResult; stdcall;
function GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow;
lpFrameInfo: POleInPlaceFrameInfo): HResult; stdcall;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HResult; stdcall;
function GetContextMenu(seltype: Word; const oleobj: IOleObject;
const chrg: TCharRange; out menu: HMENU): HResult; stdcall;
{$ELSE}
function QueryInterface(const iid: TIID; var Obj): HResult; override;
function AddRef: Longint; override;
function Release: Longint; override;
function GetNewStorage(var stg: IStorage): HResult; override;
function GetInPlaceContext(var Frame: IOleInPlaceFrame;
var Doc: IOleInPlaceUIWindow;
lpFrameInfo: POleInPlaceFrameInfo): HResult; override;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
var dataobj: IDataObject): HResult; override;
function GetContextMenu(seltype: Word; const oleobj: IOleObject;
const chrg: TCharRange; var menu: HMENU): HResult; override;
{$ENDIF}
function ShowContainerUI(fShow: BOOL): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
cp: Longint): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
function DeleteObject(const oleobj: IOleObject): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
function QueryAcceptData(const dataobj: IDataObject; var cfFormat: TClipFormat;
reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
function ContextSensitiveHelp(fEnterMode: BOOL): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
var dwEffect: DWORD): HResult;
{$IFDEF RX_D3} stdcall {$ELSE} override {$ENDIF};
end;
constructor TRichEditOleCallback.Create(RichEdit: TRxCustomRichEdit);
begin
inherited Create;
FRichEdit := RichEdit;
end;
destructor TRichEditOleCallback.Destroy;
begin
{$IFDEF RX_D3}
DestroyAccelTable;
FFrameForm := nil;
FDocForm := nil;
{$ENDIF}
inherited Destroy;
end;
{$IFDEF RX_D3}
function TRichEditOleCallback.QueryInterface(const iid: TGUID; out Obj): HResult;
begin
if GetInterface(iid, Obj) then Result := S_OK
else Result := E_NOINTERFACE;
end;
function TRichEditOleCallback._AddRef: Longint;
begin
Inc(FRefCount);
Result := FRefCount;
end;
function TRichEditOleCallback._Release: Longint;
begin
Dec(FRefCount);
Result := FRefCount;
end;
procedure TRichEditOleCallback.CreateAccelTable;
var
Menu: TMainMenu;
begin
if (FAccelTable = 0) and Assigned(FFrameForm) then begin
Menu := FFrameForm.Form.Menu;
if Menu <> nil then
Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]);
end;
end;
procedure TRichEditOleCallback.DestroyAccelTable;
begin
if FAccelTable <> 0 then begin
DestroyAcceleratorTable(FAccelTable);
FAccelTable := 0;
FAccelCount := 0;
end;
end;
procedure TRichEditOleCallback.AssignFrame;
begin
if (GetParentForm(FRichEdit) <> nil) and not Assigned(FFrameForm) and
FRichEdit.AllowInPlace then
begin
FDocForm := GetVCLFrameForm(ValidParentForm(FRichEdit));
FFrameForm := FDocForm;
if IsFormMDIChild(FDocForm.Form) then
FFrameForm := GetVCLFrameForm(Application.MainForm);
end;
end;
{$ELSE}
function TRichEditOleCallback.QueryInterface(const iid: TIID; var Obj): HResult;
begin
if IsEqualIID(iid, IID_IUnknown) or
IsEqualIID(iid, IID_IRichEditOleCallback) then
begin
Pointer(Obj) := Self;
AddRef;
Result := S_OK;
end else begin
Pointer(Obj) := nil;
Result := E_NOINTERFACE;
end;
end;
function TRichEditOleCallback.AddRef: Longint;
begin
Inc(FRefCount);
Result := FRefCount;
end;
function TRichEditOleCallback.Release: Longint;
begin
Dec(FRefCount);
Result := FRefCount;
end;
{$ENDIF RX_D3}
function TRichEditOleCallback.GetNewStorage(
{$IFDEF RX_D3} out {$ELSE} var {$ENDIF} stg: IStorage): HResult;
begin
try
CreateStorage(stg);
Result := S_OK;
except
Result:= E_OUTOFMEMORY;
end;
end;
function TRichEditOleCallback.GetInPlaceContext(
{$IFDEF RX_D3} out {$ELSE} var {$ENDIF} Frame: IOleInPlaceFrame;
{$IFDEF RX_D3} out {$ELSE} var {$ENDIF} Doc: IOleInPlaceUIWindow;
lpFrameInfo: POleInPlaceFrameInfo): HResult;
begin
{$IFDEF RX_D3}
AssignFrame;
if Assigned(FFrameForm) and FRichEdit.AllowInPlace then begin