www.pudn.com > RichEdit3.rar > RichEdit2Ctrl.pas
unit RichEdit2Ctrl;
interface
uses
StdCtrls, Classes, Windows, Messages, Controls, RichEdit2, SysUtils,
Printers, Graphics, Forms, ComStrs, ComObj, ActiveX, extctrls, tom_TLB,
OleCtnrs;
type
{ TReObject }
_ReObject = record
cbStruct: DWORD; { Size of structure }
cp: Longint; { 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
{ _ReObject 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) }
REO_IOB_SELECTION = $FFFFFFFF; { Current select object }
REO_CP_SELECTION = Integer($FFFFFFFF);
type
{ IRichEditOle }
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;
{ IRichEditOleCallback }
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;
{ TRichEditOleCallback }
TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
private
FOwner: TComponent;
protected
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;
public
constructor Create(AOwner: TComponent);
end;
{ TTextAttributes }
TCustomRichEdit2 = class;
TAttributeType = (atSelected, atDefaultText);
TConsistentAttribute = (caBold, caColor, caFace, caItalic,
caSize, caStrikeOut, caUnderline, caProtected);
TConsistentAttributes = set of TConsistentAttribute;
TTextAttributes = class(TPersistent)
private
RichEdit: TCustomRichEdit2;
FType: TAttributeType;
procedure GetAttributes(var Format: TCharFormat2);
function GetCharset: TFontCharset;
function GetColor: TColor;
function GetConsistentAttributes: TConsistentAttributes;
function GetHeight: Integer;
function GetName: TFontName;
function GetPitch: TFontPitch;
function GetProtected: Boolean;
function GetSize: Integer;
function GetStyle: TFontStyles;
function GetOffset: Integer;
function GetBackColor: TColor;
function GetUnderlineType: Integer;
procedure SetAttributes(var Format: TCharFormat2);
procedure SetCharset(Value: TFontCharset);
procedure SetColor(Value: TColor);
procedure SetHeight(Value: Integer);
procedure SetName(Value: TFontName);
procedure SetPitch(Value: TFontPitch);
procedure SetProtected(Value: Boolean);
procedure SetSize(Value: Integer);
procedure SetStyle(Value: TFontStyles);
procedure SetOffset(Value: Integer);
procedure SetBackColor(Value: TColor);
procedure SetUnderlineType(Value: TColor);
protected
procedure InitFormat(var Format: TCharFormat2);
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create(AOwner: TCustomRichEdit2; AttributeType: TAttributeType);
procedure Assign(Source: TPersistent); override;
property Charset: TFontCharset read GetCharset write SetCharset;
property Color: TColor read GetColor write SetColor;
property ConsistentAttributes: TConsistentAttributes read GetConsistentAttributes;
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 Style: TFontStyles read GetStyle write SetStyle;
property Height: Integer read GetHeight write SetHeight;
end;
{ TParaAttributes }
TNumberingStyle = (nsNone, nsBullet);
TParaAttributes = class(TPersistent)
private
RichEdit: TCustomRichEdit2;
procedure GetAttributes(var Paragraph: TParaFormat2);
function GetAlignment: TAlignment;
function GetFirstIndent: Longint;
function GetLeftIndent: Longint;
function GetRightIndent: Longint;
function GetNumbering: TNumberingStyle;
function GetTab(Index: Byte): Longint;
function GetTabCount: Integer;
function GetSpaceBefore: Integer;
function GetSpaceAfter: Integer;
function GetLineSpacing: Integer;
function GetLineSpacingRule: Integer;
procedure InitPara(var Paragraph: TParaFormat2);
procedure SetAlignment(Value: TAlignment);
procedure SetAttributes(var Paragraph: TParaFormat2);
procedure SetFirstIndent(Value: Longint);
procedure SetLeftIndent(Value: Longint);
procedure SetRightIndent(Value: Longint);
procedure SetNumbering(Value: TNumberingStyle);
procedure SetTab(Index: Byte; Value: Longint);
procedure SetTabCount(Value: Integer);
procedure SetSpaceBefore(Value: Integer);
procedure SetSpaceAfter(Value: Integer);
procedure SetLineSpacing(Value: Integer);
procedure SetLineSpacingRule(Value: Integer);
public
constructor Create(AOwner: TCustomRichEdit2);
procedure Assign(Source: TPersistent); override;
property Alignment: TAlignment read GetAlignment write SetAlignment;
property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
property Numbering: TNumberingStyle read GetNumbering write SetNumbering;
property RightIndent: Longint read GetRightIndent write SetRightIndent;
property Tab[Index: Byte]: Longint read GetTab write SetTab;
property TabCount: Integer read GetTabCount write SetTabCount;
property SpaceBefore: Integer read GetSpaceBefore write SetSpaceBefore;
property SpaceAfter: Integer read GetSpaceAfter write SetSpaceAfter;
property LineSpacing: Integer read GetLineSpacing write SetLineSpacing;
property LineSpacingRule: Integer read GetLineSpacingRule write SetLineSpacingRule;
end;
{ TCustomRichEdit2: Extend TCustomRichEdit, Support RichEdit 3.0 }
TRichEditResizeEvent = procedure(Sender: TObject; Rect: TRect) of object;
TRichEditProtectChange = procedure(Sender: TObject;
StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
TRichEditSaveClipboard = procedure(Sender: TObject;
NumObjects, NumChars: Integer; var SaveClipboard: Boolean) of object;
TSearchType = (stWholeWord, stMatchCase);
TSearchTypes = set of TSearchType;
{ TConversion }
TConversion = class(TObject)
public
function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
end;
TConversionClass = class of TConversion;
PConversionFormat = ^TConversionFormat;
TConversionFormat = record
ConversionClass: TConversionClass;
Extension: string;
Next: PConversionFormat;
end;
PRichEditStreamInfo = ^TRichEditStreamInfo;
TRichEditStreamInfo = record
Converter: TConversion;
Stream: TStream;
end;
{ TCustomRichEdit2 }
TVerRuler = class;
THorRuler = class;
TCustomRichEdit2 = class(TCustomMemo)
private
FHideScrollBars: Boolean;
FSelAttributes: TTextAttributes;
FDefAttributes: TTextAttributes;
FParagraph: TParaAttributes;
FOldParaAlignment: TAlignment;
FScreenLogPixels: Integer;
FRichEditStrings: TStrings;
FMemStream: TMemoryStream;
FOnSelChange: TNotifyEvent;
FHideSelection: Boolean;
FModified: Boolean;
FDefaultConverter: TConversionClass;
FOnResizeRequest: TRichEditResizeEvent;
FOnProtectChange: TRichEditProtectChange;
FOnSaveClipboard: TRichEditSaveClipboard;
FPageRect: TRect;
FRichEditOle: IRichEditOle;
FRichEditOleCallback: IRichEditOleCallback;
FTextDocument: ITextDocument;
FVerRuler: TVerRuler;
FHorRuler: THorRuler;
procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
function GetPlainText: Boolean;
function ProtectChange(StartPos, EndPos: Integer): Boolean;
function SaveClipboard(NumObj, NumChars: Integer): Boolean;
procedure SetHideScrollBars(Value: Boolean);
procedure SetHideSelection(Value: Boolean);
procedure SetPlainText(Value: Boolean);
procedure SetRichEditStrings(Value: TStrings);
procedure SetDefAttributes(Value: TTextAttributes);
procedure SetSelAttributes(Value: TTextAttributes);
procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
{ Extend TCustomRichEdit }
procedure SetAutoURLDetect(Value: Boolean);
procedure SetScrollPos(Value: TPoint);
function GetAutoURLDetect: Boolean;
function GetScrollPos: TPoint;
function GetCanRedo: Boolean;
function GetCanUndo: Boolean;
function GetRedoName: string;
function GetUndoName: string;
function GetTom: ITextDocument;
function GetRichEditOle: IRichEditOle;
procedure SetRichEditOleCallback(RichEditOleCallback: IRichEditOleCallback);
procedure SetVerRuler(Value: TVerRuler);
procedure SetHorRuler(Value: THorRuler);
procedure UpdateRuler;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure RequestSize(const Rect: TRect); virtual;
procedure SelectionChange; dynamic;
procedure DoSetMaxLength(Value: Integer); override;
function GetCaretPos: TPoint; override;
function GetSelLength: Integer; override;
function GetSelStart: Integer; override;
function GetSelText: string; override;
procedure SetSelLength(Value: Integer); override;
procedure SetSelStart(Value: Integer); override;
property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
property HideScrollBars: Boolean read FHideScrollBars
write SetHideScrollBars default True;
property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard
write FOnSaveClipboard;
property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;
property OnProtectChange: TRichEditProtectChange read FOnProtectChange
write FOnProtectChange;
property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest
write FOnResizeRequest;
property PlainText: Boolean read GetPlainText write SetPlainText default False;
property RichEditOle: IRichEditOle read GetRichEditOle;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Clear; override;
function FindText(const SearchStr: string;
StartPos, Length: Integer; Options: TSearchTypes): Integer;
function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override;
procedure Print(const Caption: string); virtual;
class procedure RegisterConversionFormat(const AExtension: string;
AConversionClass: TConversionClass);
property DefaultConverter: TConversionClass
read FDefaultConverter write FDefaultConverter;
property DefAttributes: TTextAttributes read FDefAttributes write SetDefAttributes;
property SelAttributes: TTextAttributes read FSelAttributes write SetSelAttributes;
property PageRect: TRect read FPageRect write FPageRect;
property Paragraph: TParaAttributes read FParagraph;
property VerRuler: TVerRuler read FVerRuler write SetVerRuler;
property HorRuler: THorRuler read FHorRuler write SetHorRuler;
{ Extend TCustomRichEdit }
procedure SetZoom(Numerator, Denominator: Integer);
procedure GetZoom(var Numerator, Denominator: Integer);
property AutoURLDetect: Boolean read GetAutoURLDetect write SetAutoURLDetect;
property ScrollPos: TPoint read GetScrollPos write SetScrollPos;
property CanRedo: Boolean read GetCanRedo;
property CanUndo: Boolean read GetCanUndo;
property RedoName: string read GetRedoName;
property UndoName: string read GetUndoName;
function InsertObjectDialog: Boolean;
procedure SetTypographyOptions(Value: Boolean);
property TOM: ITextDocument read GetTom;
end;
{ TRichEdit2 }
TRichEdit2 = class(TCustomRichEdit2)
published
property Align;
property Alignment;
property Anchors;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property Color;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HideScrollBars;
property ImeMode;
property ImeName;
property Constraints;
property Lines;
property MaxLength;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PlainText;
property PopupMenu;
property ReadOnly;
property ScrollBars;
property ShowHint;
property TabOrder;
property TabStop default True;
property Visible;
property WantTabs;
property WantReturns;
property WordWrap;
property OnChange;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnProtectChange;
property OnResizeRequest;
property OnSaveClipboard;
property OnSelectionChange;
property OnStartDock;
property OnStartDrag;
property HorRuler;
property VerRuler;
property AutoURLDetect;
end;
{-----------------------------------------------------------------------}
TIndentMarker = class;
TBorderMarker = class;
TNewTabkind = class;
TTabKind = Integer;
TIndentMarkerType = (imFirst, imLeft, imRight, imBrdRight, imBrdLeft);
TRulerDrawOption = (doShowNumbers, doShowLines, doShow3DLines);
TRulerDrawOptions = set of TRulerDrawOption;
TRulerOption = (roShowTabSelector, roShowTabStops, roHideIndentMarker,
roUseIntervalls, roUpdateAtOnce, roDrawIndentLine, roKeepMarksVisible);
TRulerOptions = set of TRulerOption;
TRulerUnit = (ruCentimeter, ruInch);
{ TRulerPanel }
TRulerPanel = class(TCustomPanel)
private
FOptions: TRulerOptions;
FDrawOptions: TRulerDrawOptions;
FTextAreaColor, FLabelColor: TColor;
FUnit: TRulerUnit;
FResolution: Integer;
FRulerRect: TRect;
FRulerTop, FRulerWidth: Integer;
FRichEdit: TCustomRichEdit2;
FMinValue, FMaxValue: Integer;
FOrigin: Integer;
procedure SetOptions(RulerOptions: TRulerOptions);
procedure SetResolution(i: Integer);
procedure SetTextAreaColor(Color: TColor);
procedure SetLabelColor(Color: TColor);
procedure SetRulerRect(Rect: TRect);
procedure SetDrawOptions(RulerDrawOptions: TRulerDrawOptions);
procedure SetRulerTop(Top: Integer);
procedure SetRulerWidth(Width: Integer);
procedure SetUnit(Value: TRulerUnit);
procedure SetOrigin(Value: Integer);
protected
FLeftMark, FFirstMark, FRightMark: TIndentMarker;
FRightBorder, FLeftBorder: TBorderMarker;
FSwitchTabKind: TNewTabkind;
FTabKind: TTabKind;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
property Resolution: Integer read FResolution write SetResolution;
property RichEdit: TCustomRichEdit2 read FRichEdit write FRichEdit;
procedure SetIndent(First, Left, Right: Longint); virtual;
property TextAreaColor: TColor read FTextAreaColor write SetTextAreaColor;
property LabelColor: TColor read FLabelColor write SetLabelColor;
property Options: TRulerOptions read FOptions write SetOptions;
property RulerRect: TRect read FRulerRect write SetRulerRect;
property RulerTop: Integer read FRulerTop write SetRulerTop;
property RulerWidth: Integer read FRulerWidth write SetRulerWidth;
property DrawOptions: TRulerDrawOptions read FDrawOptions write SetDrawOptions;
property RulerUnit: TRulerUnit read FUnit write SetUnit;
property FirstMark: TIndentMarker read FFirstMark;
property LeftMark: TIndentMarker read FLeftMark;
property RightMark: TIndentMarker read FRightMark;
property Origin: Integer read FOrigin write SetOrigin;
end;
TVerRuler = class(TRulerPanel)
published
property Align;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property DragCursor;
property DragMode;
property Enabled;
property Color;
property Ctl3D;
property Font;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDrag;
property Anchors;
property Constraints;
property Options;
property TextAreaColor;
property LabelColor;
// property InnerBorder;
// property DrawOptions;
// property Units;
property RulerTop;
property RulerWidth;
property DrawOptions;
end;
{ It is not achieve }
THorRuler = class(TRulerPanel)
published
property Align;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property DragCursor;
property DragMode;
property Enabled;
property Color;
property Ctl3D;
property Font;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDrag;
property Anchors;
property Constraints;
property Options;
property TextAreaColor;
property LabelColor;
// property InnerBorder;
// property DrawOptions;
// property Units;
property RulerTop;
property RulerWidth;
property RulerUnit;
property DrawOptions;
end;
{ TNewTabkind }
TNewTabkind = class(TGraphicControl)
private
FRuler: TRulerPanel;
protected
procedure Click; override;
procedure Paint; override;
end;
{ TIndentMarker }
TIndentMarker = class(TGraphicControl)
private
FType: TIndentMarkerType;
FDown, FMoving: Boolean;
FValue: Integer;
FLastX: Integer;
FMinValue, FMaxValue: Integer;
procedure SetValue(Value: Integer);
procedure SetMinValue(Value: Integer);
procedure SetMaxValue(Value: Integer);
protected
FRuler: TRulerPanel;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure Paint; override;
procedure UpdateState;
public
constructor Create(AOwner: TComponent); override;
property Value: Integer read FValue write SetValue;
property MinValue: Integer read FMinValue write SetMinValue;
property MaxValue: Integer read FMaxValue write SetMaxValue;
end;
{ TBorderMarker }
TBorderMarker = class(TIndentMarker)
protected
procedure Paint; override;
end;
function TwipsToPixels(Value: Integer): Integer;
function PrinterPixelsToTwipsX(Value: Integer): Integer;
function PixelsToTwipsX(Value: Integer): Integer;
function BooleanToTom(Value: Boolean): Integer;
function TomToBoolean(Value: Integer): Boolean;
procedure Register;
implementation
uses
OleDlg, Clipbrd;
procedure Register;
begin
RegisterComponents('ExtControl', [TRichEdit2]);
RegisterComponents('ExtControl', [THorRuler]);
end;
const
RTFConversionFormat: TConversionFormat = (
ConversionClass: TConversion;
Extension: 'rtf';
Next: nil);
TextConversionFormat: TConversionFormat = (
ConversionClass: TConversion;
Extension: 'txt';
Next: @RTFConversionFormat);
TWIPSPERINCH = 1440;
UndoNames: array[0..5] of string = ('', '键入', '删除', '移动', '剪切', '粘贴');
RulerAdj = 3/4;
var
ConversionFormatList: PConversionFormat = @TextConversionFormat;
FRichEditModule: THandle;
{ Comm Function }
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
Result := OleObject.QueryInterface(IOleCache, OleCache);
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
EnumStatData := nil;
end;
end;
finally
OleCache := nil;
end;
if Succeeded(Result) and (DrawAspect <> DVASPECT_ICON) then
OleObject.Update;
end;
end;
{ TConversion }
function TConversion.ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
begin
Result := Stream.Read(Buffer^, BufSize);
end;
function TConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
begin
Result := Stream.Write(Buffer^, BufSize);
end;
{ TRichEditStrings }
const
ReadError = $0001;
WriteError = $0002;
NoError = $0000;
type
TSelection = record
StartPos, EndPos: Integer;
end;
TRichEditStrings = class(TStrings)
private
RichEdit: TCustomRichEdit2;
FPlainText: Boolean;
FConverter: TConversion;
procedure EnableChange(const Value: Boolean);
protected
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
procedure Put(Index: Integer; const S: string); override;
procedure SetUpdateState(Updating: Boolean); override;
procedure SetTextStr(const Value: string); override;
public
destructor Destroy; override;
procedure Clear; override;
procedure AddStrings(Strings: TStrings); override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
procedure LoadFromFile(const FileName: string); override;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToFile(const FileName: string); override;
procedure SaveToStream(Stream: TStream); override;
property PlainText: Boolean read FPlainText write FPlainText;
end;
destructor TRichEditStrings.Destroy;
begin
FConverter.Free;
inherited Destroy;
end;
procedure TRichEditStrings.AddStrings(Strings: TStrings);
var
SelChange: TNotifyEvent;
begin
SelChange := RichEdit.OnSelectionChange;
RichEdit.OnSelectionChange := nil;
try
inherited AddStrings(Strings);
finally
RichEdit.OnSelectionChange := SelChange;
end;
end;
function TRichEditStrings.GetCount: Integer;
begin
Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;
function TRichEditStrings.Get(Index: Integer): string;
var
Text: array[0..4095] of Char;
L: Integer;
begin
Word((@Text)^) := SizeOf(Text);
L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
SetString(Result, Text, L);
end;
procedure TRichEditStrings.Put(Index: Integer; const S: string);
var
Selection: TCharRange;
begin
if Index >= 0 then
begin
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := Selection.cpMin +
SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
end;
end;
end;
procedure TRichEditStrings.Insert(Index: Integer; const S: string);
var
L: Integer;
Selection: TCharRange;
Fmt: PChar;
Str: string;
begin
if Index >= 0 then
begin
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin >= 0 then Fmt := '%s'#13#10
else begin
Selection.cpMin :=
SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
if Selection.cpMin < 0 then Exit;
L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
if L = 0 then Exit;
Inc(Selection.cpMin, L);
Fmt := #13#10'%s';
end;
Selection.cpMax := Selection.cpMin;
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
Str := Format(Fmt, [S]);
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));
// 1.0 uses, 2.0 will error happened
// if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
// raise EOutOfResources.Create(sRichEditInsertError);
end;
end;
procedure TRichEditStrings.Delete(Index: Integer);
const
Empty: PChar = '';
var
Selection: TCharRange;
begin
if Index < 0 then Exit;
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0);
if Selection.cpMax = -1 then
Selection.cpMax := Selection.cpMin +
SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
end;
end;
procedure TRichEditStrings.Clear;
begin
RichEdit.Clear;
end;
procedure TRichEditStrings.SetUpdateState(Updating: Boolean);
begin
if RichEdit.Showing then
SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
if not Updating then begin
RichEdit.Refresh;
RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
end;
end;
procedure TRichEditStrings.EnableChange(const Value: Boolean);
var
EventMask: Longint;
begin
with RichEdit do
begin
if Value then
EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
else
EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
end;
end;
procedure TRichEditStrings.SetTextStr(const Value: string);
begin
EnableChange(False);
try
inherited SetTextStr(Value);
finally
EnableChange(True);
end;
end;
function AdjustLineBreaks(Dest, Source: PChar): Integer; assembler;
asm
PUSH ESI
PUSH EDI
MOV EDI,EAX
MOV ESI,EDX
MOV EDX,EAX
CLD
@@1: LODSB
@@2: OR AL,AL
JE @@4
CMP AL,0AH
JE @@3
STOSB
CMP AL,0DH
JNE @@1
MOV AL,0AH
STOSB
LODSB
CMP AL,0AH
JE @@1
JMP @@2
@@3: MOV EAX,0A0DH
STOSW
JMP @@1
@@4: STOSB
LEA EAX,[EDI-1]
SUB EAX,EDX
POP EDI
POP ESI
end;
function StreamSave(dwCookie: Longint; pbBuff: PByte;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
StreamInfo: PRichEditStreamInfo;
begin
Result := NoError;
StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
try
pcb := 0;
if StreamInfo^.Converter <> nil then
pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, PChar(pbBuff), cb);
except
Result := WriteError;
end;
end;
function StreamLoad(dwCookie: Longint; pbBuff: PByte;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
Buffer, pBuff: PChar;
StreamInfo: PRichEditStreamInfo;
begin
Result := NoError;
StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
Buffer := StrAlloc(cb + 1);
try
cb := cb div 2;
pcb := 0;
pBuff := Buffer + cb;
try
if StreamInfo^.Converter <> nil then
pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pBuff, cb);
if pcb > 0 then
begin
pBuff[pcb] := #0;
if pBuff[pcb - 1] = #13 then pBuff[pcb - 1] := #0;
pcb := AdjustLineBreaks(Buffer, pBuff);
Move(Buffer^, pbBuff^, pcb);
end;
except
Result := ReadError;
end;
finally
StrDispose(Buffer);
end;
end;
procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then Converter := FConverter
else Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then TextType := SF_TEXT
else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position := Position;
if PlainText then TextType := SF_RTF
else TextType := SF_TEXT;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then Converter.Free;
end;
end;
procedure TRichEditStrings.SaveToStream(Stream: TStream);
var
EditStream: TEditStream;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
if FConverter <> nil then Converter := FConverter
else Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Stream := Stream;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamSave;
dwError := 0;
end;
if PlainText then TextType := SF_TEXT
else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMOUT, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditSaveFail);
finally
if FConverter = nil then Converter.Free;
end;
end;
procedure TRichEditStrings.LoadFromFile(const FileName: string);
var
Ext: string;
Convert: PConversionFormat;
begin
Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
System.Delete(Ext, 1, 1);
Convert := ConversionFormatList;
while Convert <> nil do
with Convert^ do
if Extension <> Ext then Convert := Next
else Break;
if Convert = nil then
Convert := @TextConversionFormat;
if FConverter = nil then FConverter := Convert^.ConversionClass.Create;
try
inherited LoadFromFile(FileName);
except
FConverter.Free;
FConverter := nil;
raise;
end;
RichEdit.DoSetMaxLength($7FFFFFF0);
end;
procedure TRichEditStrings.SaveToFile(const FileName: string);
var
Ext: string;
Convert: PConversionFormat;
begin
Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
System.Delete(Ext, 1, 1);
Convert := ConversionFormatList;
while Convert <> nil do
with Convert^ do
if Extension <> Ext then Convert := Next
else Break;
if Convert = nil then
Convert := @TextConversionFormat;
if FConverter = nil then FConverter := Convert^.ConversionClass.Create;
try
inherited SaveToFile(FileName);
except
FConverter.Free;
FConverter := nil;
raise;
end;
end;
{ TRichEditOleCallback }
constructor TRichEditOleCallback.Create(AOwner: TComponent);
begin
inherited Create;
FOwner:= AOwner;
end;
function TRichEditOleCallback.GetNewStorage(out stg: IStorage): HRESULT;
var
LockBytes: ILockBytes;
begin
Result:= S_OK;
try
OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE
or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, stg));
except
Result:= E_OUTOFMEMORY;
end;
end;
function TRichEditOleCallback.GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow;
lpFrameInfo: POleInPlaceFrameInfo): HResult;
begin
result := E_NOTIMPL;
end;
function TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HRESULT;
begin
result := E_NOTIMPL;
end;
function TRichEditOleCallback.QueryInsertObject(const clsid: TCLSID; const stg: IStorage;
cp: Longint): HResult;
begin
Result:= S_OK;
end;
function TRichEditOleCallback.DeleteObject(const oleobj: IOleObject): HResult; stdcall;
begin
Result:= S_OK;
end;
function TRichEditOleCallback.QueryAcceptData(const dataobj: IDataObject;
var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;
hMetaPict: HGLOBAL): HResult;
begin
Result:= S_OK;
end;
function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HRESULT;
begin
Result:= E_NOTIMPL;
end;
function TRichEditOleCallback.GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HRESULT;
begin
Result:= E_NOTIMPL;
end;
function TRichEditOleCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
var dwEffect: DWORD): HRESULT;
const
MK_ALT = $20;
var
Effect: DWORD;
begin
Result:= S_OK;
if not fDrag then
begin
// check for force link
if ((grfKeyState and (MK_CONTROL or MK_SHIFT)) = (MK_CONTROL or MK_SHIFT)) then
Effect := DROPEFFECT_LINK
// check for force copy
else if ((grfKeyState and MK_CONTROL) = MK_CONTROL) then
Effect := DROPEFFECT_COPY
// check for force move
else if ((grfKeyState and MK_ALT) = MK_ALT) then
Effect := DROPEFFECT_MOVE
// default -- recommended action is move
else
Effect := DROPEFFECT_MOVE;
if (Effect and dwEffect <> 0) then // make sure allowed type
dwEffect := Effect;
end;
end;
function TRichEditOleCallback.GetContextMenu(seltype: Word; const oleobj: IOleObject;
const chrg: TCharRange; out menu: HMENU): HResult;
begin
Result:= E_NOTIMPL;
end;
{ TTextAttributes }
constructor TTextAttributes.Create(AOwner: TCustomRichEdit2;
AttributeType: TAttributeType);
begin
inherited Create;
RichEdit := AOwner;
FType := AttributeType;
end;
procedure TTextAttributes.InitFormat(var Format: TCharFormat2);
begin
FillChar(Format, SizeOf(TCharFormat2), 0);
Format.cbSize := SizeOf(TCharFormat2);
end;
function TTextAttributes.GetConsistentAttributes: TConsistentAttributes;
var
Format: TCharFormat2;
begin
Result := [];
if RichEdit.HandleAllocated and (FType = atSelected) then
begin
InitFormat(Format);
SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
WPARAM(FType = atSelected), LPARAM(@Format));
with Format do
begin
if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold);
if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor);
if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace);
if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic);
if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize);
if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut);
if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline);
if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected);
end;
end;
end;
procedure TTextAttributes.GetAttributes(var Format: TCharFormat2);
begin
InitFormat(Format);
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
WPARAM(FType = atSelected), LPARAM(@Format));
end;
procedure TTextAttributes.SetAttributes(var Format: TCharFormat2);
var
Flag: Longint;
begin
if FType = atSelected then Flag := SCF_SELECTION
else Flag := 0;
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, Flag, LPARAM(@Format))
end;
function TTextAttributes.GetCharset: TFontCharset;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.bCharset;
end;
procedure TTextAttributes.SetCharset(Value: TFontCharset);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_CHARSET;
bCharSet := Value;
end;
SetAttributes(Format);
end;
function TTextAttributes.GetProtected: Boolean;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
with Format do
if (dwEffects and CFE_PROTECTED) <> 0 then
Result := True else
Result := False;
end;
procedure TTextAttributes.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 TTextAttributes.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 TTextAttributes.SetColor(Value: TColor);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_COLOR;
if Value = clWindowText then
dwEffects := CFE_AUTOCOLOR else
crTextColor := ColorToRGB(Value);
end;
SetAttributes(Format);
end;
function TTextAttributes.GetName: TFontName;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.szFaceName;
end;
procedure TTextAttributes.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 TTextAttributes.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;
function TTextAttributes.GetOffset: Integer;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.yOffset;
end;
function TTextAttributes.GetBackColor: TColor;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.crTextColor;
end;
function TTextAttributes.GetUnderlineType: Integer;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.bUnderlineType;
end;
procedure TTextAttributes.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;
procedure TTextAttributes.SetOffset(Value: Integer);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_FACE;
yOffset := Value;
end;
SetAttributes(Format);
end;
procedure TTextAttributes.SetBackColor(Value: TColor);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_BACKCOLOR;
crTextColor := ColorToRGB(Value);
end;
SetAttributes(Format);
end;
procedure TTextAttributes.SetUnderlineType(Value: TColor);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_BACKCOLOR;
bUnderlineType := Value;
end;
SetAttributes(Format);
end;
function TTextAttributes.GetSize: Integer;
var
Format: TCharFormat2;
begin
GetAttributes(Format);
Result := Format.yHeight div 20;
end;
procedure TTextAttributes.SetSize(Value: Integer);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
dwMask := CFM_SIZE;
yHeight := Value * 20;
end;
SetAttributes(Format);
end;
function TTextAttributes.GetHeight: Integer;
begin
Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
end;
procedure TTextAttributes.SetHeight(Value: Integer);
begin
Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
end;
function TTextAttributes.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 TTextAttributes.SetPitch(Value: TFontPitch);
var
Format: TCharFormat2;
begin
InitFormat(Format);
with Format do
begin
case Value of
fpVariable: Format.bPitchAndFamily := VARIABLE_PITCH;
fpFixed: Format.bPitchAndFamily := FIXED_PITCH;
else
Format.bPitchAndFamily := DEFAULT_PITCH;
end;
end;
SetAttributes(Format);
end;
procedure TTextAttributes.Assign(Source: TPersistent);
begin
if Source is TFont then
begin
Color := TFont(Source).Color;
Name := TFont(Source).Name;
Charset := TFont(Source).Charset;
Style := TFont(Source).Style;
Size := TFont(Source).Size;
Pitch := TFont(Source).Pitch;
end
else if Source is TTextAttributes then
begin
Color := TTextAttributes(Source).Color;
Name := TTextAttributes(Source).Name;
Charset := TTextAttributes(Source).Charset;
Style := TTextAttributes(Source).Style;
Pitch := TTextAttributes(Source).Pitch;
end
else inherited Assign(Source);
end;
procedure TTextAttributes.AssignTo(Dest: TPersistent);
begin
if Dest is TFont then
begin
TFont(Dest).Color := Color;
TFont(Dest).Name := Name;
TFont(Dest).Charset := Charset;
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;
TTextAttributes(Dest).Charset := Charset;
TTextAttributes(Dest).Style := Style;
TTextAttributes(Dest).Pitch := Pitch;
end
else inherited AssignTo(Dest);
end;
{ TParaAttributes }
constructor TParaAttributes.Create(AOwner: TCustomRichEdit2);
begin
inherited Create;
RichEdit := AOwner;
end;
procedure TParaAttributes.InitPara(var Paragraph: TParaFormat2);
begin
FillChar(Paragraph, SizeOf(TParaFormat2), 0);
Paragraph.cbSize := SizeOf(TParaFormat2);
end;
procedure TParaAttributes.GetAttributes(var Paragraph: TParaFormat2);
begin
InitPara(Paragraph);
if RichEdit.HandleAllocated then
SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
end;
procedure TParaAttributes.SetAttributes(var Paragraph: TParaFormat2);
begin
RichEdit.HandleNeeded; { we REALLY need the handle for BiDi }
if RichEdit.HandleAllocated then
begin
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;
SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph));
end;
end;
function TParaAttributes.GetAlignment: TAlignment;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := TAlignment(Paragraph.wAlignment - 1);
end;
procedure TParaAttributes.SetAlignment(Value: TAlignment);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_ALIGNMENT;
wAlignment := Ord(Value) + 1;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes.GetNumbering: TNumberingStyle;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := TNumberingStyle(Paragraph.wNumbering);
end;
procedure TParaAttributes.SetNumbering(Value: TNumberingStyle);
var
Paragraph: TParaFormat2;
begin
case Value of
nsBullet: if LeftIndent < 10 then LeftIndent := 10;
nsNone: LeftIndent := 0;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NUMBERING;
wNumbering := Ord(Value);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes.GetFirstIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxStartIndent div 20
end;
procedure TParaAttributes.SetFirstIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_STARTINDENT;
dxStartIndent := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes.GetLeftIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxOffset div 20;
end;
procedure TParaAttributes.SetLeftIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_OFFSET;
dxOffset := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes.GetRightIndent: Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dxRightIndent div 20;
end;
procedure TParaAttributes.SetRightIndent(Value: Longint);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_RIGHTINDENT;
dxRightIndent := Value * 20;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes.GetTab(Index: Byte): Longint;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.rgxTabs[Index] div 20;
end;
procedure TParaAttributes.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 TParaAttributes.GetTabCount: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.cTabCount;
end;
function TParaAttributes.GetSpaceBefore: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dySpaceBefore;
end;
function TParaAttributes.GetSpaceAfter: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dySpaceAfter;
end;
function TParaAttributes.GetLineSpacing: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.dyLineSpacing;
end;
function TParaAttributes.GetLineSpacingRule: Integer;
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
Result := Paragraph.bLineSpacingRule;
end;
procedure TParaAttributes.SetTabCount(Value: Integer);
var
Paragraph: TParaFormat2;
begin
GetAttributes(Paragraph);
with Paragraph do
begin
dwMask := PFM_TABSTOPS;
cTabCount := Value;
SetAttributes(Paragraph);
end;
end;
procedure TParaAttributes.SetSpaceBefore(Value: Integer);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SPACEBEFORE;
dySpaceBefore := Value;
end;
SetAttributes(Paragraph);
end;
procedure TParaAttributes.SetSpaceAfter(Value: Integer);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SPACEAFTER;
dySpaceBefore := Value;
end;
SetAttributes(Paragraph);
end;
procedure TParaAttributes.SetLineSpacing(Value: Integer);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_LINESPACING;
dyLineSpacing := Value;
end;
SetAttributes(Paragraph);
end;
procedure TParaAttributes.SetLineSpacingRule(Value: Integer);
var
Paragraph: TParaFormat2;
begin
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_LINESPACING;
bLineSpacingRule := Value;
end;
SetAttributes(Paragraph);
end;
procedure TParaAttributes.Assign(Source: TPersistent);
var
I: Integer;
begin
if Source is TParaAttributes then
begin
Alignment := TParaAttributes(Source).Alignment;
FirstIndent := TParaAttributes(Source).FirstIndent;
LeftIndent := TParaAttributes(Source).LeftIndent;
RightIndent := TParaAttributes(Source).RightIndent;
Numbering := TParaAttributes(Source).Numbering;
for I := 0 to MAX_TAB_STOPS - 1 do
Tab[I] := TParaAttributes(Source).Tab[I];
end
else inherited Assign(Source);
end;
{ TCustomRichEdit2 }
constructor TCustomRichEdit2.Create(AOwner: TComponent);
var
DC: HDC;
begin
inherited Create(AOwner);
FSelAttributes := TTextAttributes.Create(Self, atSelected);
FDefAttributes := TTextAttributes.Create(Self, atDefaultText);
FParagraph := TParaAttributes.Create(Self);
FRichEditStrings := TRichEditStrings.Create;
TRichEditStrings(FRichEditStrings).RichEdit := Self;
TabStop := True;
Width := 185;
Height := 89;
AutoSize := False;
DoubleBuffered := False;
FHideSelection := True;
HideScrollBars := True;
DC := GetDC(0);
FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
DefaultConverter := TConversion;
ReleaseDC(0, DC);
FOldParaAlignment := Alignment;
Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
FRichEditOleCallback := TRichEditOleCallback.Create(self);
end;
destructor TCustomRichEdit2.Destroy;
begin
FSelAttributes.Free;
FDefAttributes.Free;
FParagraph.Free;
FRichEditStrings.Free;
FMemStream.Free;
inherited Destroy;
end;
procedure TCustomRichEdit2.Clear;
begin
inherited Clear;
Modified := False;
end;
procedure TCustomRichEdit2.CreateParams(var Params: TCreateParams);
const
//1.0使用RICHED32.DLL
//2.0、3.0使用RICHED20.DLL
RichEditModuleName = 'RICHED20.DLL';
HideScrollBars: array[Boolean] of DWORD = (ES_DISABLENOSCROLL, 0);
HideSelections: array[Boolean] of DWORD = (ES_NOHIDESEL, 0);
begin
if FRichEditModule = 0 then
begin
FRichEditModule := LoadLibrary(RichEditModuleName);
if FRichEditModule <= HINSTANCE_ERROR then FRichEditModule := 0;
end;
inherited CreateParams(Params);
//Unicode use 'RichEdit20W'
CreateSubClass(Params, 'RichEdit20A');
with Params do
begin
Style := Style or HideScrollBars[FHideScrollBars] or
HideSelections[HideSelection];
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TCustomRichEdit2.CreateWnd;
var
Plain, DesignMode, WasModified: Boolean;
begin
WasModified := inherited Modified;
inherited CreateWnd;
if (SysLocale.FarEast) and not (SysLocale.PriLangID = LANG_JAPANESE) then
Font.Charset := GetDefFontCharSet;
SendMessage(Handle, EM_SETEVENTMASK, 0,
ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
ENM_PROTECTED);
SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));
SetRichEditOleCallback(FRichEditOleCallback);
if FMemStream <> nil then
begin
Plain := PlainText;
FMemStream.ReadBuffer(DesignMode, sizeof(DesignMode));
PlainText := DesignMode;
try
Lines.LoadFromStream(FMemStream);
FMemStream.Free;
FMemStream := nil;
finally
PlainText := Plain;
end;
end;
Modified := WasModified;
end;
procedure TCustomRichEdit2.DestroyWnd;
var
Plain, DesignMode: Boolean;
begin
FModified := Modified;
FMemStream := TMemoryStream.Create;
Plain := PlainText;
DesignMode := (csDesigning in ComponentState);
PlainText := DesignMode;
FMemStream.WriteBuffer(DesignMode, sizeof(DesignMode));
try
Lines.SaveToStream(FMemStream);
FMemStream.Position := 0;
finally
PlainText := Plain;
end;
inherited DestroyWnd;
end;
procedure TCustomRichEdit2.WMNCDestroy(var Message: TWMNCDestroy);
begin
inherited;
end;
procedure TCustomRichEdit2.WMSetFont(var Message: TWMSetFont);
begin
FDefAttributes.Assign(Font);
end;
procedure TCustomRichEdit2.WMRButtonUp(var Message: TWMRButtonUp);
begin
// RichEd20 does not pass the WM_RBUTTONUP message to defwndproc,
// so we get no WM_CONTEXTMENU message. Simulate message here.
if Win32MajorVersion < 5 then
Perform(WM_CONTEXTMENU, Handle, LParam(PointToSmallPoint(
ClientToScreen(SmallPointToPoint(Message.Pos)))));
inherited;
end;
procedure TCustomRichEdit2.CMFontChanged(var Message: TMessage);
begin
FDefAttributes.Assign(Font);
end;
procedure TCustomRichEdit2.DoSetMaxLength(Value: Integer);
begin
SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);
end;
function TCustomRichEdit2.GetCaretPos;
var
CharRange: TCharRange;
begin
SendMessage(Handle, EM_EXGETSEL, 0, LongInt(@CharRange));
Result.X := CharRange.cpMax;
Result.Y := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, Result.X);
Result.X := Result.X - SendMessage(Handle, EM_LINEINDEX, -1, 0);
end;
function TCustomRichEdit2.GetSelLength: Integer;
var
CharRange: TCharRange;
begin
SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
Result := CharRange.cpMax - CharRange.cpMin;
end;
function TCustomRichEdit2.GetSelStart: Integer;
var
CharRange: TCharRange;
begin
SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
Result := CharRange.cpMin;
end;
function TCustomRichEdit2.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
var
S: string;
begin
S := GetSelText;
Result := Length(S);
if BufSize < Length(S) then Result := BufSize;
StrPLCopy(Buffer, S, Result);
end;
function TCustomRichEdit2.GetSelText: string;
var
Length: Integer;
begin
SetLength(Result, GetSelLength + 1);
Length := SendMessage(Handle, EM_GETSELTEXT, 0, Longint(PChar(Result)));
SetLength(Result, Length);
end;
procedure TCustomRichEdit2.CMBiDiModeChanged(var Message: TMessage);
var
AParagraph: TParaFormat2;
begin
HandleNeeded; { we REALLY need the handle for BiDi }
inherited;
Paragraph.GetAttributes(AParagraph);
AParagraph.dwMask := PFM_ALIGNMENT;
AParagraph.wAlignment := Ord(Alignment) + 1;
Paragraph.SetAttributes(AParagraph);
end;
procedure TCustomRichEdit2.SetHideScrollBars(Value: Boolean);
begin
if HideScrollBars <> Value then
begin
FHideScrollBars := value;
RecreateWnd;
end;
end;
procedure TCustomRichEdit2.SetHideSelection(Value: Boolean);
begin
if HideSelection <> Value then
begin
FHideSelection := Value;
SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LongInt(True));
end;
end;
procedure TCustomRichEdit2.SetSelAttributes(Value: TTextAttributes);
begin
SelAttributes.Assign(Value);
end;
procedure TCustomRichEdit2.SetSelLength(Value: Integer);
var
CharRange: TCharRange;
begin
SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
CharRange.cpMax := CharRange.cpMin + Value;
SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
SendMessage(Handle, EM_SCROLLCARET, 0, 0);
end;
procedure TCustomRichEdit2.SetDefAttributes(Value: TTextAttributes);
begin
DefAttributes.Assign(Value);
end;
function TCustomRichEdit2.GetPlainText: Boolean;
begin
Result := TRichEditStrings(Lines).PlainText;
end;
procedure TCustomRichEdit2.SetPlainText(Value: Boolean);
begin
TRichEditStrings(Lines).PlainText := Value;
end;
procedure TCustomRichEdit2.CMColorChanged(var Message: TMessage);
begin
inherited;
SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color))
end;
procedure TCustomRichEdit2.SetRichEditStrings(Value: TStrings);
begin
FRichEditStrings.Assign(Value);
end;
procedure TCustomRichEdit2.SetSelStart(Value: Integer);
var
CharRange: TCharRange;
begin
CharRange.cpMin := Value;
CharRange.cpMax := Value;
SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
end;
procedure TCustomRichEdit2.Print(const Caption: string);
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY, OldMap: Integer;
SaveRect: TRect;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Printer, Range do
begin
Title := Caption;
BeginDoc;
hdc := Handle;
hdcTarget := hdc;
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
if IsRectEmpty(PageRect) then
begin
rc.right := PageWidth * 1440 div LogX;
rc.bottom := PageHeight * 1440 div LogY;
end
else begin
rc.left := PageRect.Left * 1440 div LogX;
rc.top := PageRect.Top * 1440 div LogY;
rc.right := PageRect.Right * 1440 div LogX;
rc.bottom := PageRect.Bottom * 1440 div LogY;
end;
rcPage := rc;
SaveRect := rc;
LastChar := 0;
MaxLen := GetTextLen;
chrg.cpMax := -1;
// ensure printer DC is in text map mode
OldMap := SetMapMode(hdc, MM_TEXT);
SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); // flush buffer
try
repeat
rc := SaveRect;
chrg.cpMin := LastChar;
LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
until (LastChar >= MaxLen) or (LastChar = -1);
EndDoc;
finally
SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); // flush buffer
SetMapMode(hdc, OldMap); // restore previous map mode
end;
end;
end;
var
Painting: Boolean = False;
procedure TCustomRichEdit2.WMPaint(var Message: TWMPaint);
var
R, R1: TRect;
begin
if GetUpdateRect(Handle, R, True) then
begin
with ClientRect do R1 := Rect(Right - 3, Top, Right, Bottom);
if IntersectRect(R, R, R1) then InvalidateRect(Handle, @R1, True);
end;
if Painting then
Invalidate
else begin
Painting := True;
try
inherited;
finally
Painting := False;
end;
end;
end;
procedure TCustomRichEdit2.WMSetCursor(var Message: TWMSetCursor);
var
P: TPoint;
begin
inherited;
if Message.Result = 0 then
begin
Message.Result := 1;
GetCursorPos(P);
with PointToSmallPoint(P) do
case Perform(WM_NCHITTEST, 0, MakeLong(X, Y)) of
HTVSCROLL,
HTHSCROLL:
Windows.SetCursor(Screen.Cursors[crArrow]);
HTCLIENT:
Windows.SetCursor(Screen.Cursors[crIBeam]);
end;
end;
end;
procedure TCustomRichEdit2.CNNotify(var Message: TWMNotify);
begin
with Message do
case NMHdr^.code of
EN_SELCHANGE: SelectionChange;
EN_REQUESTRESIZE: RequestSize(PReqSize(NMHdr)^.rc);
EN_SAVECLIPBOARD:
with PENSaveClipboard(NMHdr)^ do
if not SaveClipboard(cObjectCount, cch) then Result := 1;
EN_PROTECTED:
with PENProtected(NMHdr)^.chrg do
if not ProtectChange(cpMin, cpMax) then Result := 1;
end;
end;
function TCustomRichEdit2.SaveClipboard(NumObj, NumChars: Integer): Boolean;
begin
Result := True;
if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result);
end;
function TCustomRichEdit2.ProtectChange(StartPos, EndPos: Integer): Boolean;
begin
Result := False;
if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result);
end;
procedure TCustomRichEdit2.SelectionChange;
begin
UpdateRuler;
if Assigned(OnSelectionChange) then OnSelectionChange(Self);
end;
procedure TCustomRichEdit2.RequestSize(const Rect: TRect);
begin
if Assigned(OnResizeRequest) then OnResizeRequest(Self, Rect);
end;
function TCustomRichEdit2.FindText(const SearchStr: string;
StartPos, Length: Integer; Options: TSearchTypes): Integer;
var
Find: TFindText;
Flags: Integer;
begin
with Find.chrg do
begin
cpMin := StartPos;
cpMax := cpMin + Length;
end;
Flags := 0;
if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
Find.lpstrText := PChar(SearchStr);
Result := SendMessage(Handle, EM_FINDTEXT, Flags, LongInt(@Find));
end;
procedure AppendConversionFormat(const Ext: string; AClass: TConversionClass);
var
NewRec: PConversionFormat;
begin
New(NewRec);
with NewRec^ do
begin
Extension := AnsiLowerCaseFileName(Ext);
ConversionClass := AClass;
Next := ConversionFormatList;
end;
ConversionFormatList := NewRec;
end;
class procedure TCustomRichEdit2.RegisterConversionFormat(const AExtension: string;
AConversionClass: TConversionClass);
begin
AppendConversionFormat(AExtension, AConversionClass);
end;
function TCustomRichEdit2.InsertObjectDialog: Boolean;
var
Data: TOleUIInsertObject;
NameBuffer: array[0..255] of Char;
ReObject: TReObject;
OleObject: IOleObject;
OleClientSite: IOleClientSite;
Storage: IStorage;
Selection: TCharRange;
IsNewObject: Boolean;
begin
FillChar(Data, SizeOf(Data), 0);
FillChar(NameBuffer, SizeOf(NameBuffer), 0);
FillChar(ReObject, SizeOf(TReObject), 0);
RichEditOle.GetClientSite(OleClientSite);
FRichEditOleCallback.GetNewStorage(Storage);
with Data do begin
cbStruct := SizeOf(Data);
dwFlags := IOF_SELECTCREATENEW or IOF_VERIFYSERVERSEXIST or
IOF_CREATENEWOBJECT or IOF_CREATEFILEOBJECT or IOF_CREATELINKOBJECT;
hWndOwner := Handle;
lpszFile := NameBuffer;
cchFile := SizeOf(NameBuffer);
iid := IOleObject;
oleRender := OLERENDER_DRAW;
lpIOleClientSite := OleClientSite;
lpIStorage := Storage;
ppvObj := @OleObject;
end;
if OleUIInsertObject(Data) = OLEUI_OK then
try
IsNewObject := Data.dwFlags and IOF_SELECTCREATENEW = IOF_SELECTCREATENEW;
with ReObject do begin
cbStruct := SizeOf(TReObject);
cp := REO_CP_SELECTION;
clsid := Data.clsid;
poleobj := OleObject;
pstg := Storage;
polesite := OleClientSite;
dvAspect := DVASPECT_CONTENT;
dwFlags := REO_RESIZABLE;
if IsNewObject then dwFlags := dwFlags or REO_BLANK;
OleCheck(OleSetDrawAspect(OleObject,
Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0,
Data.hMetaPict, dvAspect));
end;
SendMessage(Handle, EM_EXGETSEL, 0, Longint(@Selection));
Selection.cpMax := Selection.cpMin + 1;
OleCheck(RichEditOle.InsertObject(ReObject));
SendMessage(Handle, EM_EXSETSEL, 0, Longint(@Selection));
SendMessage(Handle, EM_SCROLLCARET, 0, 0);
RichEditOle.SetDvaspect(Longint(REO_IOB_SELECTION), ReObject.dvAspect);
finally
DestroyMetaPict(Data.hMetaPict);
end;
Result := True;
end;
procedure TCustomRichEdit2.SetAutoURLDetect(Value: Boolean);
begin
SendMessage(Handle, EM_AUTOURLDETECT, Integer(Value), 0);
end;
procedure TCustomRichEdit2.SetScrollPos(Value: TPoint);
begin
SendMessage(Handle, EM_GETSCROLLPOS, 0, Integer(@Value));
end;
function TCustomRichEdit2.GetAutoURLDetect: Boolean;
begin
Result := Boolean(SendMessage(Handle, EM_GETAUTOURLDETECT, 0, 0));
end;
function TCustomRichEdit2.GetScrollPos: TPoint;
begin
SendMessage(Handle, EM_GETSCROLLPOS, 0, Integer(@Result));
end;
procedure TCustomRichEdit2.SetZoom(Numerator, Denominator: Integer);
begin
SendMessage(Handle, EM_SETZOOM, Numerator, Denominator);
end;
procedure TCustomRichEdit2.GetZoom(var Numerator: Integer; var Denominator: Integer);
begin
SendMessage(Handle, EM_GETZOOM, Numerator, Denominator);
end;
function TCustomRichEdit2.GetCanRedo: Boolean;
begin
Result := Boolean(SendMessage(Handle, EM_CANREDO, 0, 0));
end;
function TCustomRichEdit2.GetCanUndo: Boolean;
begin
Result := Boolean(SendMessage(Handle, EM_CANUNDO, 0, 0));
end;
function TCustomRichEdit2.GetRedoName: string;
var
id: Integer;
begin
id := SendMessage(Handle, EM_GETREDONAME, 0, 0);
Result := UndoNames[id];
end;
function TCustomRichEdit2.GetUndoName: string;
var
id: Integer;
begin
id := SendMessage(Handle, EM_GETUNDONAME, 0, 0);
Result := UndoNames[id];
end;
function TCustomRichEdit2.GetTom: ITextDocument;
const
IID: TGUID = '{8CC497C0-A1DF-11CE-8098-00AA0047BE5D}';
begin
if not Assigned(FTextDocument) then
RichEditOle.QueryInterface(IID, FTextDocument);
Result := FTextDocument;
end;
function TCustomRichEdit2.GetRichEditOle: IRichEditOle;
var
OleInterface: IRichEditOle;
begin
if not Assigned(FRichEditOle) then
if LongBool(SendMessage(Handle, EM_GETOLEINTERFACE, 0, Longint(@OleInterface))) then
FRichEditOle := OleInterface
else
raise Exception.Create('Unable to get IRichEditOle');
Result := FRichEditOle;
end;
procedure TCustomRichEdit2.SetRichEditOleCallback(RichEditOleCallback: IRichEditOleCallback);
begin
if not LongBool(SendMessage(Handle, EM_SETOLECALLBACK, 0, Longint(RichEditOleCallback))) then
raise Exception.Create('Unable to get IRichEditOleCallback');
end;
procedure TCustomRichEdit2.SetVerRuler(Value: TVerRuler);
begin
FVerRuler := FVerRuler;
FVerRuler.RichEdit := self;
end;
procedure TCustomRichEdit2.SetHorRuler(Value: THorRuler);
begin
FHorRuler := Value;
FHorRuler.RichEdit := self;
end;
procedure TCustomRichEdit2.UpdateRuler;
begin
if Assigned(FHorRuler) then
with TOM.Selection.Para do
begin
FHorRuler.FirstMark.Value := Trunc(FirstLineIndent);
FHorRuler.LeftMark.Value := Trunc(LeftIndent);
FHorRuler.RightMark.Value := Trunc(RightIndent);
end;
if Assigned(FVerRuler) then
with TOM.Selection.Para do
begin
//
end;
end;
procedure TCustomRichEdit2.SetTypographyOptions(Value: Boolean);
begin
if Value then
SendMessage(Handle, EM_SETTYPOGRAPHYOPTIONS, TO_ADVANCEDTYPOGRAPHY, -1)
else
SendMessage(Handle, EM_SETTYPOGRAPHYOPTIONS, TO_SIMPLELINEBREAK, -1)
end;
{-------------------------------------------------------------------------}
{ TRulerPanel }
constructor TRulerPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFirstMark := TIndentMarker.Create(Self);
with FFirstMark do
begin
Parent := Self;
FRuler := Self;
FType := imFirst;
end;
FLeftMark := TIndentMarker.Create(Self);
with FLeftMark do
begin
Parent := Self;
FRuler := Self;
FType := imLeft;
end;
FRightMark := TIndentMarker.Create(Self);
with FRightMark do
begin
Parent := Self;
FRuler := Self;
FType := imRight;
Hide;
end;
FRulerTop := 4;
FRulerWidth := 12;
FTextAreaColor := clWhite;
FLabelColor := clBlack;
Height := 20;
FResolution := 96;
DrawOptions := [doShowNumbers, doShowLines];
Options := [roShowTabStops, roUseIntervalls, roDrawIndentLine];
FOrigin := 0;
end;
function ScreenPixelsPerInch: Integer;
var
DC: HDC;
begin
DC := GetDC(0);
Result := GetDeviceCaps(DC, LOGPIXELSY);
ReleaseDC(0, DC);
end;
function PixelsToTwipsX(Value: Integer): Integer;
begin
Result := (Value * TWIPSPERINCH) div ScreenPixelsPerInch;
end;
function BooleanToTom(Value: Boolean): Integer;
const
IntBool: array[Boolean] of Integer = (0, -1);
begin
Result := IntBool[Value];
end;
function TomToBoolean(Value: Integer): Boolean;
begin
Result := Boolean(Value);
end;
function PrinterPixelsToTwipsX(Value: Integer): Integer;
begin
Result := (Value * TWIPSPERINCH) div GetDeviceCaps(Printer.Handle, LogPixelsX);
end;
function TwipsToPixels(Value: Integer): Integer;
begin
Result:= Value * ScreenPixelsPerInch div TWIPSPERINCH;
end;
procedure TRulerPanel.Paint;
procedure CLineTo(x, y: Integer);
begin
if (x > 1) and (x < Width - 1) then
begin
Canvas.LineTo(x, y);
end;
end;
var
Rect: TRect;
x, y, w, w2, w4, w24: Integer;
Scale: string;
begin
inherited Paint;
if HandleAllocated then with Canvas do
begin
FRulerRect := Rect;
Brush.Style := bsSolid;
Brush.Color := FTextAreaColor;
Rect.Left := FOrigin;
Rect.Top := FRulerTop;
Rect.Bottom := FRulerTop + FRulerWidth;
Rect.Right := width - 1;
if Rect.Left < 1 then Rect.Left := 1;
FillRect(Rect);
Brush.Color := clBtnShadow;
Rect.Left := 1;
Rect.Right := FOrigin;
FillRect(Rect);
if FUnit = ruInch then w := Resolution
else w := Trunc(Resolution / 2.54);
x := Forigin mod w - w;
y := FRulerTop + (FRulerWidth div 2);
{ draw lines }
if doShowLines in FDrawOptions then
begin
{ Backwards }
w2 := w div 2;
w4 := w2 div 2;
w24 := w2 + w4;
Pen.Color := FLabelColor;
if w > 0 then while x < Width do
begin
if not (doShowNumbers in FDrawOptions) then
begin
MoveTo(x, y - 3);
CLineTo(x, y + 3);
end;
MoveTo(x + w4, y - 1);
CLineTo(x + w4, y + 1);
MoveTo(x + w2, y - 2);
CLineTo(x + w2, y + 2);
MoveTo(x + w24, y - 1);
CLineTo(x + w24, y + 1);
inc(x, w);
end;
end;
if (doShowNumbers in FDrawOptions) then
begin
Brush.Style := bsClear;
x := FOrigin;
y := y - 1 - TextHeight('0') div 2;
w4 := 0; { w4 做计数 }
while (x >= 0) and (x <= Width) do
begin
Scale := IntToStr(w4);
w2 := TextWidth(Scale) div 2;
TextOut(x - w2, y, Scale);
Inc(x, w);
Inc(w4);
end;
x := FOrigin;
w4 := 0;
while (x >= 0) and (x <= Width) do
begin
Scale := IntToStr(0 - w4);
w2 := TextWidth(Scale) div 2;
TextOut(x - w2, y, Scale);
Dec(x, w);
Dec(w4);
end;
end;
end;
end;
procedure TRulerPanel.Resize;
var
H: Integer;
begin
inherited Resize;
H := Height div 2 - 1;
FFirstMark.Height := H;
FLeftMark.Height := H + 2;
FRightMark.Height := H + 2;
H := Height - FLeftMark.Height;
FLeftMark.Top := H;
FRightMark.Top := H;
if Height < FRulerTop + FRulerWidth then
Height := FRulerTop + FRulerWidth;
end;
procedure TRulerPanel.SetIndent(First, Left, Right: Longint);
begin
FLeftMark.Value := Left;
FFirstMark.Value := First;
FRightMark.Value := Right;
end;
procedure TRulerPanel.SetOptions(RulerOptions: TRulerOptions);
begin
if FOptions <> RulerOptions then
begin
FOptions := RulerOptions;
end;
end;
procedure TRulerPanel.SetResolution(i: Integer);
begin
if FResolution <> i then
begin
FResolution := i;
Invalidate;
end;
end;
procedure TRulerPanel.SetTextAreaColor(Color: TColor);
begin
if FTextAreaColor <> Color then
begin
FTextAreaColor := Color;
Invalidate;
end;
end;
procedure TRulerPanel.SetLabelColor(Color: TColor);
begin
if FLabelColor <> Color then
begin
FLabelColor := Color;
Invalidate;
end;
end;
procedure TRulerPanel.SetRulerRect(Rect: TRect);
begin
if (Rect.Left <> FRulerRect.Left) or (Rect.Right <> FRulerRect.Right) or
(Rect.Top <> FRulerRect.Top) or (Rect.Bottom <> FRulerRect.Bottom) then
begin
FRulerRect := Rect;
Invalidate;
end;
end;
procedure TRulerPanel.SetDrawOptions(RulerDrawOptions: TRulerDrawOptions);
begin
if RulerDrawOptions <> FDrawOptions then
begin
FDrawOptions := RulerDrawOptions;
Invalidate;
end;
end;
procedure TRulerPanel.SetRulerTop(Top: Integer);
begin
if Top <> FRulerTop then
begin
FRulerTop := Top;
Resize;
Invalidate;
end;
end;
procedure TRulerPanel.SetRulerWidth(Width: Integer);
begin
if Width <> FRulerWidth then
begin
FRulerWidth := Width;
Resize;
Invalidate;
end;
end;
procedure TRulerPanel.SetUnit(Value: TRulerUnit);
begin
FUnit := Value;
Invalidate;
end;
procedure TRulerPanel.SetOrigin(Value: Integer);
begin
FOrigin := Value;
Invalidate;
end;
{ NewTabkind }
procedure TNewTabkind.Click;
begin
end;
procedure TNewTabkind.Paint;
var
r: TRect;
begin
inherited Paint;
if not Visible then exit;
with Canvas do
begin
r := ClientRect;
Pen.Color := clBtnShadow;
Pen.Width := 1;
Pen.Style := psSolid;
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
InflateRect(r, -1, -1);
Rectangle(r.Left, r.Top, R.Right, r.Bottom);
InflateRect(r, -1, -1);
Pen.Color := clWhite;
MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Left, R.Top);
LineTo(R.Right, R.Top);
Pen.Color := clBtnShadow;
LineTo(R.Right, R.Bottom);
LineTo(R.Left, R.Bottom);
end;
end;
{ TIndentMarker }
constructor TIndentMarker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 9;
MinValue := 0;
Value := -(Width div 2);
end;
procedure TIndentMarker.SetValue(Value: Longint);
begin
FValue := Value;
Left := Round(FValue * (1/RulerAdj)) - Width div 2;
end;
procedure TIndentMarker.SetMinValue(Value: Integer);
begin
FMinValue := Value - Width div 2;
end;
procedure TIndentMarker.SetMaxValue(Value: Integer);
begin
FMaxValue := Value - Width div 2;
end;
procedure TIndentMarker.Paint;
var
Black: TColor;
procedure DrawRightUpArrow(x, y, w, h: Integer);
var
P: array[1..6] of TPoint;
hh: Integer;
begin
hh := w div 2;
P[1].x := x;
P[1].y := y + h;
P[2].x := x;
P[2].y := y + hh;
P[3].x := x + w div 2;
P[3].y := y;
P[4].x := x + w;
P[4].y := y + hh;
P[5].x := x + w;
P[5].y := y + h;
P[6].x := x;
P[6].y := y + h;
with Canvas do
begin
Polygon(P);
Pen.Color := Black;
MoveTo(P[2].x, P[2].y);
LineTo(P[3].x, P[3].y);
LineTo(P[4].x, P[4].y);
LineTo(P[5].x, P[5].y);
LineTo(P[6].x, P[6].y);
LineTo(P[1].x, P[1].y);
end;
end;
procedure DrawUpArrow(x, y, w, h: Integer);
var
P: array[1..6] of TPoint;
hh: Integer;
begin
hh := w div 2;
P[1].x := x;
P[1].y := y + h;
P[2].x := x;
P[2].y := y + hh;
P[3].x := x + w div 2;
P[3].y := y;
P[4].x := x + w;
P[4].y := y + hh;
P[5].x := x + w;
P[5].y := y + h;
P[6].x := x;
P[6].y := y + h;
with Canvas do
begin
Polygon(P);
Pen.Color := Black;
MoveTo(P[2].x, P[2].y);
LineTo(P[3].x, P[3].y);
LineTo(P[4].x, P[4].y);
LineTo(P[5].x, P[5].y);
LineTo(P[6].x, P[6].y);
LineTo(P[1].x, P[1].y);
Pen.Color := clBtnShadow;
MoveTo(x, h - hh - 1);
LineTo(x + w, h - hh - 1);
end;
end;
procedure DrawArrow(x, y, w, h: Integer);
var
P: array[1..6] of TPoint;
hh, hr: Integer;
begin
hh := w div 2;
hr := h - hh;
P[1].x := x;
P[1].y := y;
P[2].x := x;
P[2].y := y + hr;
P[3].x := x + w div 2;
P[3].y := y + h;
P[4].x := x + w;
P[4].y := y + hr;
P[5].x := x + w;
P[5].y := y;
P[6].x := x;
P[6].y := y;
with Canvas do
begin
Polygon(P);
Pen.Color := Black;
MoveTo(P[2].x, P[2].y);
LineTo(P[1].x, P[1].y);
LineTo(P[5].x, P[5].y);
LineTo(P[4].x, P[4].y);
LineTo(P[3].x, P[3].y);
LineTo(P[2].x, P[2].y);
end;
end;
begin
with Canvas do
begin
Brush.Color := Self.Color;
Brush.Style := bsSolid;
Pen.Width := 1;
Black := clBlack;
Pen.Color := clBtnShadow;
Pen.Style := psSolid;
end;
if FType = imLeft then DrawUpArrow(0, 0, Width - 1, Height - 1)
else if FType = imRight then DrawRightUpArrow(0, 0, Width - 1, Height - 1)
else DrawArrow(0, 1, Width - 1, Height - 2);
end;
procedure TIndentMarker.UpdateState;
begin
FValue := Round((Left + Width div 2)* RulerAdj);
with FRuler.RichEdit.TOM.Selection.Para do
case FType of
imFirst:
SetIndents(FValue, Get_LeftIndent, Get_RightIndent);
imLeft:
SetIndents(Get_FirstLineIndent, FValue, Get_RightIndent);
imRight:
begin
FValue := Round((Width - Left) * RulerAdj);
SetIndents(Get_FirstLineIndent, Get_LeftIndent, FValue);
end;
end;
end;
procedure TIndentMarker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Button = mbLeft then
begin
FDown := True;
FMoving := True;
FLastX := x;
MouseCapture := True;
end;
end;
procedure TIndentMarker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
FLastX := x;
FMoving := False;
MouseCapture := False;
UpdateState;
end;
procedure TIndentMarker.MouseMove(Shift: TShiftState; X, Y: Integer);
var
OffSetPoint, Point: TPoint;
w2: Integer;
begin
if FDown and FMoving and (FRuler <> nil) then
begin
Point.x := x;
Point.y := y;
Point := ClientToScreen(Point);
OffSetPoint.x := FRuler.Left;;
Point := ClientToScreen(Point);
OffSetPoint := FRuler.Parent.ClientToScreen(OffSetPoint);
Point.x := Point.x - OffSetPoint.x;
w2 := Width div 2;
Left := ScreenToClient(Point).x - w2;
if Left < FMinValue then Left := FMinValue;
end;
end;
{ TBorderMarker }
procedure TBorderMarker.Paint;
var
Rect: TRect;
begin
if not Visible then exit;
with Canvas do
begin
Rect := ClientRect;
Pen.Color := clBtnShadow;
Pen.Width := 1;
Pen.Style := psSolid;
Brush.Style := bsSolid;
InflateRect(Rect, -1, -1);
Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, -1, -1);
Pen.Color := clWhite;
MoveTo(Rect.Left, Rect.Bottom - 1);
LineTo(Rect.Left, Rect.Top);
LineTo(Rect.Right, Rect.Top);
Pen.Color := clBtnShadow;
LineTo(Rect.Right, Rect.Bottom);
LineTo(Rect.Left, Rect.Bottom);
end;
end;
end.