admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 22:45:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/POWERCAD30/UNITS/RichEdit2.pas
ShevaIV 00e2ad8635 initial commit
2025-05-12 10:07:51 +03:00

5425 lines
148 KiB
ObjectPascal
Raw Blame History

unit RichEdit2;
{
TRichEdit98 and DBRichEdit98 components for Delphi 3.0-4.0. version 1.40
Author Alexander Obukhov, Minsk, Belarus <alex@niiomr.belpak.minsk.by>
OLE support code written by
Greg Chapman <glc@well.com>
Mike Lindre <MikeL@chemware.co.uk>
Tomasz Kustra <tom_kust@friko5.onet.pl>
Sigi <medcom@tm.net.my>
Thanks to:
Oliver Matla <wolfpack@eulink.net>
Glenn Benes <gjbenes@infocompii.com>
Sven Opitz <S.Opitz@Cardy.de>
Jolios Lin <jolios3@mail.photin.com.tw>
Tom Wang <wangtao@netchina.com.cn>
Doron Tal <dorontal@netvision.net.il>
Alexander Halser <halser@easycash.co.at>
Arentjan Banck <ajbanck@davilex.nl>
Andre Van Der Merwe <dart@iafrica.com>
Iain Magee <iain@swiftsoft.net>
Sigi <medcom@tm.net.my>
Rob Schoenaker <rschoenaker@kraan.com>
Laszlo Kovacs <kovacsl@westel900.net>
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ComStrs, RichEdit, PCTypesUtils,
WStrList, //DB, DBCtrls,
ActiveX,OleCtnrs,olectrls,ComObj,OleDlg,RichOle,Menus, Printers;
const
FT_DOWNWARD = 1;
const
DataFormatCount = 2;
var CF_RTF: Cardinal;
CF_RTFNOOBJS: Cardinal = 0;
CF_RETEXTOBJ: Cardinal = 0;
type
{ The declarations of TTextRangeA and TTextRangeW in Richedit.pas are incorrect}
TTextRangeA = record
chrg: TCharRange;
lpstrText: PAnsiChar; {not AnsiChar!}
end;
TTextRangeW = record
chrg: TCharRange;
lpstrText: PWideChar; {not WideChar!}
end;
TTextRange = TTextRangeA;
TInputFormat=(ifText, ifRTF, ifUnicode);
TOutputFormat=(ofText, ofRTF, ofRTFNoObjs, ofTextized, ofUnicode);
TSearchType98 = (stBackward, stWholeWord, stMatchCase);
TSearchTypes98 = set of TSearchType98;
TCustomRichEdit98 = class;
TConsistentAttribute98 = (caBold, caColor, caFace, caItalic,
caSize, caStrikeOut, caUnderline, caProtected, caWeight,
caBackColor, caLanguage, caIndexKind, caOffset, caSpacing,
caKerning, caULType, caAnimation, caSmallCaps, caAllCaps,
caHidden, caOutline, caShadow, caEmboss, caImprint, caURL);
TConsistentAttributes98 = set of TConsistentAttribute98;
TIndexKind = (ikNone, ikSubscript, ikSuperscript);
TUnderlineType = (ultNone, ultSingle, ultWord, ultDouble, ultDotted, ultWave,
ultThick, ultHair, ultDashDD, ultDashD, ultDash);
TAnimationType = (aniNone, aniLasVegas, aniBlink, aniSparkle, aniBlackAnts,
aniRedAnts, aniShimmer);
TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
private
FOwner: TCustomRichEdit98;
protected
function GetNewStorage(out stg: IStorage): HRESULT; stdcall;
function GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo): HRESULT; stdcall;
function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;
function QueryInsertObject(const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT; stdcall;
function DeleteObject(oleobj: IOLEObject): HRESULT; stdcall;
function QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HRESULT; stdcall;
function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
var dwEffect: DWORD): HRESULT; stdcall;
function GetContextMenu(seltype: Word; oleobj: IOleObject;
const chrg: TCharRange; var menu: HMENU): HRESULT; stdcall;
public
constructor Create(AOwner: TCustomRichEdit98);
end;
TTextAttributes98 = class(TPersistent)
private
RichEdit: TCustomRichEdit98;
FType: TAttributeType;
FOldAttr: TTextattributes;
procedure GetAttributes(var Format: TCharFormat2W);
function GetConsistentAttributes: TConsistentAttributes98;
procedure SetAttributes(var Format: TCharFormat2W);
protected
procedure InitFormat(var Format: TCharFormat2W);
procedure AssignTo(Dest: TPersistent); override;
function GetColor: TColor;
procedure SetColor(Value: TColor);
function GetName: TFontName;
procedure SetName(Value: TFontName);
function GetPitch: TFontPitch;
procedure SetPitch(Value: TFontPitch);
function GetProtected: Boolean;
procedure SetProtected(Value: Boolean);
function GetSize: Integer;
procedure SetSize(Value: Integer);
function GetHeight: Integer;
procedure SetHeight(Value: Integer);
function GetWeight: Word;
procedure SetWeight(Value: Word);
function GetBackColor: TColor;
procedure SetBackColor(Value: TColor);
function GetLanguage: TLanguage;
procedure SetLanguage(Value: TLanguage);
function GetIndexKind: TIndexKind;
procedure SetIndexKind(Value: TIndexKind);
function GetOffset: Double;
procedure SetOffset(Value: Double);
function GetSpacing: Double;
procedure SetSpacing(Value: Double);
function GetKerning: Double;
procedure SetKerning(Value: Double);
function GetUnderlineType: TUnderlineType;
procedure SetUnderlineType(Value: TUnderlineType);
function GetAnimation: TAnimationType;
procedure SetAnimation(Value: TAnimationType);
function GetBold: Boolean;
procedure SetBold(Value: Boolean);
function GetItalic: Boolean;
procedure SetItalic(Value: Boolean);
function GetStrikeOut: Boolean;
procedure SetStrikeOut(Value: Boolean);
function GetSmallCaps: Boolean;
procedure SetSmallCaps(Value: Boolean);
function GetAllCaps: Boolean;
procedure SetAllCaps(Value: Boolean);
function GetHidden: Boolean;
procedure SetHidden(Value: Boolean);
function GetOutline: Boolean;
procedure SetOutline(Value: Boolean);
function GetShadow: Boolean;
procedure SetShadow(Value: Boolean);
function GetEmboss: Boolean;
procedure SetEmboss(Value: Boolean);
function GetImprint: Boolean;
procedure SetImprint(Value: Boolean);
function GetStyle: TFontStyles;
procedure SetStyle(Value: TFontStyles);
function GetIsURL: Boolean;
procedure SetIsURL(Value: Boolean);
public
constructor Create(AOwner: TCustomRichEdit98; AttributeType: TAttributeType);
procedure Assign(Source: TPersistent); override;
property ConsistentAttributes: TConsistentAttributes98 read GetConsistentAttributes;
property Color: TColor read GetColor write SetColor;
property Name: TFontName read GetName write SetName;
property Pitch: TFontPitch read GetPitch write SetPitch;
property Protected: Boolean read GetProtected write SetProtected;
property Size: Integer read GetSize write SetSize;
property Height: Integer read GetHeight write SetHeight;
property Weight: Word read GetWeight write SetWeight;
property BackColor: TColor read GetBackColor write SetBackColor;
property Language: TLanguage read GetLanguage write SetLanguage;
property IndexKind: TIndexKind read GetIndexKind write SetIndexKind;
property Offset: Double read GetOffset write SetOffset;
property Spacing: Double read GetSpacing write SetSpacing;
property Kerning: Double read GetKerning write SetKerning;
property UnderlineType: TUnderlineType read GetUnderlineType write SetUnderlineType;
property Animation: TAnimationType read GetAnimation write SetAnimation;
property Bold: Boolean read GetBold write SetBold;
property Italic: Boolean read GetItalic write SetItalic;
property StrikeOut: Boolean read GetStrikeOut write SetStrikeOut;
property SmallCaps: Boolean read GetSmallCaps write SetSmallCaps;
property AllCaps: Boolean read GetAllCaps write SetAllCaps;
property Hidden: Boolean read GetHidden write SetHidden;
property Outline: Boolean read GetOutline write SetOutline;
property Shadow: Boolean read GetShadow write SetShadow;
property Emboss: Boolean read GetEmboss write SetEmboss;
property Imprint: Boolean read GetImprint write SetImprint;
property Style: TFontStyles read GetStyle write SetStyle;
property IsURL: Boolean read GetIsURL write SetIsURL;
end;
TLineSpacingRule = (lsrOrdinary, lsr15, lsrDouble, lsrAtLeast, lsrExactly,
lsrMultiple);
TAlignment98 = (taLeft, taRight, taCenter, taJustify);
TNumberingStyle98 = (nsNone, nsBullet, nsNumber, nsLowerCase, nsUpperCase,
nsLowerRoman, nsUpperRoman, nsSequence);
TNumberingFollow = (nfParenthesis, nfPeriod, nfEncloseParenthesis);
TBorderLocation = (blLeft, blRight, blTop, blBottom, blInside, blOutside);
TBorderLocations = set of TBorderLocation;
TBorderStyle = (bsNone, bs15, bs30, bs45, bs60, bs90, bs120, bs15Dbl,
bs30Dbl, bs45Dbl, bs15Gray, bs15GrayDashed);
TShadingWeight = 0..100;
TShadingStyle = (shsNone, shsDarkHorizontal, shsDarkVertical, shsDarkDownDiagonal,
shsDarkUpDiagonal, shsDarkGrid, shsDarkTrellis, shsLightHorizontal,
shsLightVertical, shsLightDownDiagonal, shsLightUpDiagonal,
shsLightGrid, shsLightTrellis);
TTabAlignment = (tbaLeft, tbaCenter, tbaRight, tbaDecimal, tbaWordBar);
TTabLeader = (tblNone, tblDotted, tblDashed, tblUnderlined, tblThick, tblDouble);
TParaAttributes98 = class(TParaAttributes)
private
RichEdit: TCustomRichEdit98;
procedure GetAttributes(var Paragraph: TParaFormat2);
procedure InitPara(var Paragraph: TParaFormat2);
procedure SetAttributes(var Paragraph: TParaFormat2);
function GetFirstIndent: Double;
procedure SetFirstIndent(Value: Double);
function GetLeftIndent: Double;
procedure SetLeftIndent(Value: Double);
function GetRightIndent: Double;
procedure SetRightIndent(Value: Double);
function GetSpaceBefore: Double;
procedure SetSpaceBefore(Value: Double);
function GetSpaceAfter: Double;
procedure SetSpaceAfter(Value: Double);
function GetLineSpacing: Double;
function GetLineSpacingRule: TLineSpacingRule;
function GetKeepTogether: Boolean;
procedure SetKeepTogether(Value: Boolean);
function GetKeepWithNext: Boolean;
procedure SetKeepWithNext(Value: Boolean);
function GetPageBreakBefore: Boolean;
procedure SetPageBreakBefore(Value: Boolean);
function GetNoLineNumber: Boolean;
procedure SetNoLineNumber(Value: Boolean);
function GetNoWidowControl: Boolean;
procedure SetNoWidowControl(Value: Boolean);
function GetDoNotHyphen: Boolean;
procedure SetDoNotHyphen(Value: Boolean);
function GetSideBySide: Boolean;
procedure SetSideBySide(Value: Boolean);
function GetAlignment: TAlignment98;
procedure SetAlignment(Value: TAlignment98);
function GetNumbering: TNumberingStyle98;
procedure SetNumbering(Value: TNumberingStyle98);
function GetNumberingStart: Word;
procedure SetNumberingStart(Value: Word);
function GetNumberingFollow: TNumberingFollow;
procedure SetNumberingFollow(Value: TNumberingFollow);
function GetNumberingTab: Double;
procedure SetNumberingTab(Value: Double);
function GetBorderSpace: Double;
function GetBorderWidth: Double;
function GetBorderLocations: TBorderLocations;
function GetBorderStyle: TBorderStyle;
function GetBorderColor: TColor;
function GetShadingWeight: TShadingWeight;
function GetShadingStyle: TShadingStyle;
function GetShadingColor: TColor;
function GetShadingBackColor: TColor;
function GetTabCount: Integer;
function GetTab(Index: Integer): Double;
function GetTabAlignment(Index: Integer): TTabAlignment;
function GetTabLeader(Index: Integer): TTabLeader;
public
constructor Create(AOwner: TCustomRichEdit98);
property Alignment: TAlignment98 read GetAlignment write SetAlignment;
property FirstIndent: Double read GetFirstIndent write SetFirstIndent;
property LeftIndent: Double read GetLeftIndent write SetLeftIndent;
property RightIndent: Double read GetRightIndent write SetRightIndent;
property SpaceBefore: Double read GetSpaceBefore write SetSpaceBefore;
property SpaceAfter: Double read GetSpaceAfter write SetSpaceAfter;
procedure SetLineSpacing(Rule: TLineSpacingRule; Value: Double);
property LineSpacing: Double read GetLineSpacing;
property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule;
property KeepTogether: Boolean read GetKeepTogether write SetKeepTogether;
property KeepWithNext: Boolean read GetKeepWithNext write SetKeepWithNext;
property PageBreakBefore: Boolean read GetPageBreakBefore write SetPageBreakBefore;
property NoLineNumber: Boolean read GetNoLineNumber write SetNoLineNumber;
property NoWidowControl: Boolean read GetNoWidowControl write SetNoWidowControl;
property DoNotHyphen: Boolean read GetDoNotHyphen write SetDoNotHyphen;
property SideBySide: Boolean read GetSideBySide write SetSideBySide;
property Numbering: TNumberingStyle98 read GetNumbering write SetNumbering;
property NumberingStart: Word read GetNumberingStart write SetNumberingStart;
property NumberingFollow: TNumberingFollow read GetNumberingFollow write SetNumberingFollow;
property NumberingTab: Double read GetNumberingTab write SetNumberingTab;
property BorderSpace: Double read GetBorderSpace;
property BorderWidth: Double read GetBorderWidth;
property BorderLocations: TBorderLocations read GetBorderLocations;
property BorderStyle: TBorderStyle read GetBorderStyle;
property BorderColor: TColor read GetBorderColor;
procedure SetBorder(Space, Width: Double; Locations: TBorderLocations;
Style: TBorderStyle; Color: TColor);
property ShadingWeight: TShadingWeight read GetShadingWeight;
property ShadingStyle: TShadingStyle read GetShadingStyle;
property ShadingColor: TColor read GetShadingColor;
property ShadingBackColor: TColor read GetShadingBackColor;
procedure SetShading(Weight: TShadingWeight; Style: TShadingStyle;
Color, BackColor: TColor);
property TabCount: Integer read GetTabCount;
property Tab[Index: Integer]: Double read GetTab;
property TabAlignment[Index: Integer]: TTabAlignment read GetTabAlignment;
property TabLeader[Index: Integer]: TTabLeader read GetTabLeader;
procedure SetTab(Index: Integer; Value: Double; Alignment: TTabAlignment;
Leader: TTabLeader);
end;
TURLClickEvent = procedure(Sender: TObject; URL: String) of object;
TURLMoveEvent = procedure(Sender: TObject; URL: String) of object;
TRichEditProgressEvent = procedure(Sender: TObject; Pos, Size: Integer) of object;
TUndoName = (unUnknown, unTyping, unDelete, unDragDrop, unCut, unPaste);
TLangOption = (loAutoKeyboard, loAutoFont, loIMECancelComplete, loIMEAlwaysSendNotify);
TLangOptions = set of TLangOption;
TSelType = (stText, stObject, stMultiChar, stMultiObject);
TSelectionType = set of TSelType;
TAutoURLDetect = (adNone, adDefault, adExtended);
TURLType = class(TCollectionItem)
private
FName: String;
FColor: TColor;
FCursor: Tcursor;
FUnderline: Boolean;
protected
function GetDisplayName: string; override;
public
procedure Assign(Source: TPersistent); override;
published
property Name: String read FName write FName;
property Color: TColor read FColor write FColor;
property Cursor: TCursor read FCursor write FCursor;
property Underline: Boolean read FUnderline write FUnderline;
end;
TURLCollection = class(TCollection)
private
FOwner: TCustomRichEdit98;
protected
function GetOwner: TPersistent; override;
procedure SetItems(Index: Integer; Value: TURLType);
function GetItems(Index: Integer): TURLType;
public
procedure AddURLType(const Name: String; Color: TColor;
Cursor: TCursor; Underline: Boolean);
property Owner: TCustomRichEdit98 read FOwner;
property Items[Index: Integer]: TURLType read GetItems write SetItems; default;
end;
TCustomRichEdit98 = class(TCustomRichEdit)
private
{ Private declarations }
FUpdateCount: Integer;
FLibHandle: THandle;
FSelAttributes: TTextAttributes98;
FDefAttributes: TTextAttributes98;
FParagraph: TParaAttributes98;
FRichEditStrings: TStrings;
FWideStrings: TWideStrings;
FScreenLogPixels: Integer;
FAutoURLDetect: TAutoURLDetect;
FShowSelBar: Boolean;
FOnURLClick: TURLClickEvent;
FOnURLMove: TURLMoveEvent;
FOnSaveProgress: TRichEditProgressEvent;
FOnLoadProgress: TRichEditProgressEvent;
FURLColor: TColor;
FURLCursor: TCursor;
FLanguage: TLanguage;
FCP: Word;
FWide: Boolean;
FStreamSel: Boolean;
FStoreSS,
FStoreSL,
FStoreFVL: Integer;
FCROld: TCharRange;
FVer10: Boolean;
// FPlainText: Boolean;
FLangOptions: TLangOptions;
FDefWndProcW: TFNWndProc;
FDefWndProcA: TFNWndProc;
FURLs: TURLCollection;
FWordFormatting: Boolean;
FUndoLimit: Integer;
FPlainTextIn: TInputFormat;
FPlainTextOut: TOutputFormat;
FSelectedInOut: Boolean;
FPlainRTF: Boolean;
FPopupVerbMenu: TPopupMenu;
FAutoVerbMenu: Boolean;
FObjectVerbs: TStringList;
FSelObject: IOleObject;
FDrawAspect: Longint;
FViewSize: TPoint;
FIncludeOLE:Boolean;
FAllowInPlace: Boolean;
FOleInPlaceObject: IOleInPlaceObject;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
FDocForm: IVCLFrameForm;
Frame:ToleForm;
procedure DestroyVerbs;
procedure UpdateVerbs;
procedure PopupVerbMenuClick(Sender: TObject);
procedure DoVerb(Verb: Integer);
function GetCanPaste: Boolean;
procedure UpdateObject;
procedure UpdateView;
procedure SetIncludeOLE(Value:Boolean);
function GetIconMetaPict: HGlobal;
procedure CheckObject;
procedure SetDrawAspect(Iconic: Boolean; IconMetaPict: HGlobal);
property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;
procedure SetDefAttributes(Value: TTextAttributes98);
procedure SetSelAttributes(Value: TTextAttributes98);
procedure SetShowSelBar(Value: Boolean);
procedure SetRichEditStrings(Value: TStrings);
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure WMDestroy(var Msg: TMessage); message WM_DESTROY;
function PrivatePerform(Msg: Cardinal; WParam, LParam: Longint): Longint;
procedure BeginUpdate;
procedure EndUpdate;
procedure FindNonSpace(var CR: TCharRange);
procedure DetectURLs(CR: TCharRange);
protected
{ Protected declarations }
procedure CreateWnd; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DefineProperties(Filer: TFiler); override;
procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT;
procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT;
procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure EMReplaceSel(var Message: TMessage); message EM_REPLACESEL;
procedure EMGetSelText(var Message: TMessage); message EM_GETSELTEXT;
procedure EMGetTextRange(var Message: TMessage); message EM_GETTEXTRANGE;
procedure EMGetLine(var Message: TMessage); message EM_GETLINE;
procedure EMStreamIn(var Message: TMessage); message EM_STREAMIN;
procedure EMStreamOut(var Message: TMessage); message EM_STREAMOUT;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure DoSetMaxLength(Value: Integer); override;
function GetLine: Integer;
procedure SetLine(Value: Integer);
function GetColumn: Integer;
procedure SetColumn(Value: Integer);
procedure SetAutoURLDetect(Value: TAutoURLDetect);
function GetFirstVisibleLine: Integer;
property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
procedure ReadData(Reader: TReader);
procedure WriteData(Writer: TWriter);
function GetWideText: WideString;
procedure SetWideText(Value: WideString);
procedure SetLanguage(Value: TLanguage);
function GetWideSelText: WideString;
procedure SetWideSelText(Value: WideString);
property OnURLClick: TURLClickEvent read FOnURLClick write FOnURLClick;
property OnURLMove: TURLMoveEvent read FOnURLMove write FOnURLMove;
property OnSaveProgress: TRichEditProgressEvent read FOnSaveProgress write FOnSaveProgress;
property OnLoadProgress: TRichEditProgressEvent read FOnLoadProgress write FOnLoadProgress;
procedure CreateWindowHandle(const Params: TCreateParams); override;
procedure SetLangOptions(Value: TLangOptions);
procedure SetCustomURLs(Value: TURLCollection);
procedure CloseOLEObjects;
procedure CreateOLEObjectInterface;
function GetPopupMenu: TPopupMenu; override;
procedure SetRTFSelText(Value: String);
function GetRTFSelText: String;
function GetSelType: TSelectionType;
procedure SetUndoLimit(Value: Integer);
public
{ Public declarations }
RichEditOle: IRichEditOle;
RichEditOleCallback: IRichEditOleCallback;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function ObjectSelected:Boolean;
procedure Clear; override;
procedure CreateLinkToFile(const FileName: string; Iconic: Boolean);
procedure CreateObject(const OleClassName: string; Iconic: Boolean);
procedure CreateObjectFromFile(const FileName: string; Iconic: Boolean);
procedure CreateObjectFromInfo(const CreateInfo: TCreateInfo);
procedure InsertObjectDialog;
function PasteSpecialDialog: Boolean;
function ChangeIconDialog: Boolean;
property AutoVerbMenu: boolean read FAutoVerbMenu write FAutoVerbMenu default true;
property InputFormat: TInputFormat read FPlainTextIn write FPlainTextIn;
property OutputFormat: TOutputFormat read FPlainTextOut write FPlainTextOut;
property SelectedInOut: Boolean read FSelectedInOut write FSelectedInOut;
property PlainRTF: Boolean read FPlainRTF write FPlainRTF;
procedure InsertFromFile(const FileName: String);
property Line: Integer read GetLine write SetLine;
property Col: Integer read GetColumn write SetColumn;
procedure SetCaret(Line, Column: Integer);
property DefAttributes: TTextAttributes98 read FDefAttributes write SetDefAttributes;
property SelAttributes: TTextAttributes98 read FSelAttributes write SetSelAttributes;
property Paragraph: TParaAttributes98 read FParagraph;
property ShowSelectionBar: Boolean read FShowSelBar write SetShowSelBar;
property WordFormatting: Boolean read FWordFormatting write FWordFormatting default True;
function FindText(const SearchStr: string;
StartPos, Length: Integer; Options: TSearchTypes98): Integer;
function FindWideText(const SearchStr: WideString;
StartPos, Length: Integer; Options: TSearchTypes98): Integer;
function CanUndo: Boolean;
procedure Undo;
function UndoName: TUndoName;
function CanRedo: Boolean;
procedure Redo;
function RedoName: TUndoName;
procedure StopGroupTyping;
property AutoURLDetect: TAutoURLDetect read FAutoURLDetect write SetAutoURLDetect;
property FirstVisibleLine: Integer read GetFirstVisibleLine;
//function GetWordAtPos(Pos: Integer; var Start, Len: Integer): String;
function GetWordAtPos(Pos: Integer; var Start, Len: Integer): AnsiString;
property RTFSelText: String read GetRTFSelText write SetRTFSelText;
property WideText: WideString read GetWideText write SetWideText;
property Language: TLanguage read FLanguage write SetLanguage;
property LangOptions: TLangOptions read FLangOptions write SetLangOptions;
property WideLines: TWideStrings read FWideStrings stored False;
property WideSelText: WideString read GetWideSelText write SetWideSelText;
property CustomURLs: TURLCollection read FURLs write SetCustomURLs;
function CharAtPos(Pos: TPoint): Integer;
property IncludeOLE: Boolean read FIncludeOLE write SetIncludeOLE default False;
property CanPaste: Boolean read GetCanPaste;
property URLColor : TColor read FURLColor write FURLColor;
property URLCursor : TCursor read FURLCursor write FURLCursor;
property SelType: TSelectionType read GetSelType;
property UndoLimit: Integer read FUndoLimit write SetUndoLimit;
end;
TRichEdit98 = class(TCustomRichEdit98)
published
{ Published declarations }
property Align;
property Alignment;
property AutoURLDetect;
property BorderStyle;
property Color;
property Ctl3D;
property CustomURLs;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HideScrollBars;
property ImeMode;
property ImeName;
property LangOptions;
property Language;
property Lines stored False;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
// property PlainText;
property PopupMenu;
property ReadOnly;
property ScrollBars;
property ShowHint;
property ShowSelectionBar;
property TabOrder;
property TabStop default True;
property URLColor;
property URLCursor;
property Visible;
property WantTabs;
property WantReturns;
property WordFormatting;
property WordWrap;
property OnChange;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnLoadProgress;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResizeRequest;
property OnSelectionChange;
property OnSaveProgress;
property OnStartDrag;
property OnProtectChange;
property OnSaveClipboard;
property OnURLClick;
property OnURLMove;
property AutoVerbMenu;
property InputFormat;
property OutputFormat;
property SelectedInOut;
property PlainRTF;
property UndoLimit;
property IncludeOLE;
property AllowInPlace;
{$IFDEF VER120}
property Anchors;
property BiDiMode;
property BorderWidth;
property Constraints;
property DragKind;
property ParentBiDiMode;
{$ENDIF}
end;
(*
TDBRichEdit98 = class(TCustomRichEdit98)
private
FDataLink: TFieldDataLink;
FAutoDisplay: Boolean;
FFocused: Boolean;
FMemoLoaded: Boolean;
FDataSave: string;
procedure BeginEditing;
procedure DataChange(Sender: TObject);
procedure EditingChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetReadOnly: Boolean;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure SetReadOnly(Value: Boolean);
procedure SetAutoDisplay(Value: Boolean);
procedure SetFocused(Value: Boolean);
procedure UpdateData(Sender: TObject);
procedure WMCut(var Message: TMessage); message WM_CUT;
procedure WMPaste(var Message: TMessage); message WM_PASTE;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
protected
procedure DefineProperties(Filer: TFiler); override;
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Loaded; override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadMemo;
property Field: TField read GetField;
published
property Align;
property Alignment;
property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
property AutoURLDetect;
property BorderStyle;
property Color;
property Ctl3D;
property CustomURLs;
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HideScrollBars;
property ImeMode;
property ImeName;
property Language;
property LangOptions;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
// property PlainText;
property PopupMenu;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
property ScrollBars;
property ShowHint;
property ShowSelectionBar;
property TabOrder;
property TabStop;
property Visible;
property WantReturns;
property WantTabs;
property WordFormatting;
property WordWrap;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnLoadProgress;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResizeRequest;
property OnSaveProgress;
property OnSelectionChange;
property OnProtectChange;
property OnSaveClipboard;
property OnStartDrag;
property OnURLClick;
property AutoVerbMenu;
property InputFormat;
property OutputFormat;
property SelectedInOut;
property PlainRTF;
property UndoLimit;
property IncludeOLE;
property AllowInPlace;
{$IFDEF VER120}
property Anchors;
property BiDiMode;
property BorderWidth;
property Constraints;
property DragKind;
property ParentBiDiMode;
{$ENDIF}
end; *)
const
RTFConversionFormat: TConversionFormat = (
ConversionClass: TConversion;
Extension: 'rtf';
{Next: nil});
TextConversionFormat: TConversionFormat = (
ConversionClass: TConversion;
Extension: 'txt';
{Next: @RTFConversionFormat});
var
ConversionFormatList: PConversionFormat = @TextConversionFormat;
procedure Register;
implementation
(*
uses
DsgnIntf, TypInfo, RTFEditor;
*)
var
PixPerInch: TPoint;
CFObjectDescriptor: Integer;
CFEmbeddedObject: Integer;
CFLinkSource: Integer;
DataFormats: array[0..DataFormatCount - 1] of TFormatEtc;
// Tolik 24/05/2019 - -
Function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
theStream: TStream;
dataAvail: LongInt;
begin
theStream := TStream(dwCookie);
with theStream do begin
dataAvail := Size - Position;
if dataAvail <= cb then begin
pcb := Read(pbBuff^, dataAvail);
Result := 0;
end
else begin
pcb := Read(pbBuff^, cb);
Result := pcb;
end;
end;
end;
Function EditStreamOutCallback(dwCookie: Longint; pbBuff: PByte;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
theStream: TStream;
begin
theStream := TStream(dwCookie);
with theStream do begin
If cb > 0 Then Begin
pcb := Write(pbBuff^, cb);
Result := pcb;
End
Else
Result := 0;
end;
end;
Procedure GetRTFSelection( aRichEdit: TRichEdit; intoStream: TStream );
Var
editstream: TEditStream;
Begin
With editstream Do Begin
dwCookie:= Longint(intoStream);
dwError:= 0;
pfnCallback:= EditStreamOutCallBack;
end;
aRichedit.Perform( EM_STREAMOUT, SF_RTF or SFF_SELECTION,
longint(@editstream));
End;
Procedure PutRTFSelection( aRichEdit: TRichEdit; sourceStream: TStream );
Var
editstream: TEditStream;
Begin
With editstream Do Begin
dwCookie:= Longint(sourceStream);
dwError:= 0;
pfnCallback:= EditStreamInCallBack;
end;
aRichedit.Perform( EM_STREAMIN, SF_RTF or SFF_SELECTION,
longint(@editstream));
End;
//
function PixelsToHimetric(const P: TPoint): TPoint;
begin
Result.X := MulDiv(P.X, 2540, PixPerInch.X);
Result.Y := MulDiv(P.Y, 2540, PixPerInch.Y);
end;
procedure CenterWindow(Wnd: HWnd);
var
Rect: TRect;
begin
GetWindowRect(Wnd, Rect);
SetWindowPos(Wnd, 0,
(GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
(GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 3,
0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
function OleDialogHook(Wnd: HWnd; Msg, WParam, LParam: Longint): Longint; stdcall;
begin
Result := 0;
if Msg = WM_INITDIALOG then
begin
if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0 then
Wnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
CenterWindow(Wnd);
Result := 1;
end;
end;
function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
begin
if Form.OleFormObject = nil then TOleForm.Create(Form);
Result := Form.OleFormObject as IVCLFrameForm;
end;
(*
type
TRTFProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
function GetValue: string; override;
end;
*)
procedure Register;
begin
//RegisterPropertyEditor(TypeInfo(TStrings), TRichEdit98, 'Lines', TRTFProperty);
//RegisterComponents('Win32', [TRichEdit98]);
//RegisterComponents('Data Controls', [TDBRichEdit98]);
//Langs.Register;
end;
var
IsWinNT: Boolean;
{ TTextAttributes98}
constructor TTextAttributes98.Create(AOwner: TCustomRichEdit98;
AttributeType: TAttributeType);
begin
inherited Create;
RichEdit := AOwner;
FType := AttributeType;
if RichEdit.FVer10 then
case FType of
atSelected:
FOldAttr:= TRichEdit(Richedit).SelAttributes;
atDefaultText:
FOldAttr:= TRichEdit(Richedit).DefAttributes;
end;
end;
procedure TTextAttributes98.InitFormat(var Format: TCharFormat2W);
begin
FillChar(Format, SizeOf(TCharFormat2W), 0);
Format.cbSize := SizeOf(TCharFormat2W);
end;
function TTextAttributes98.GetConsistentAttributes: TConsistentAttributes98;
var
Format: TCharFormat2W;
begin
Result := [];
if RichEdit.HandleAllocated and (FType = atSelected) then
begin
InitFormat(Format);
RichEdit.Perform(EM_GETCHARFORMAT,
WPARAM(FType = atSelected), LPARAM(@Format));
with Format do
begin
if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold);
if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor);
if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace);
if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic);
if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize);
if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut);
if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline);
if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected);
if (dwMask and CFM_WEIGHT) <> 0 then Include(Result, caWeight);
if (dwMask and CFM_BACKCOLOR) <> 0 then Include(Result, caBackColor);
if (dwMask and CFM_LCID) <> 0 then Include(Result, caLanguage);
if (dwMask and CFM_SUPERSCRIPT) <> 0 then Include(Result, caIndexKind);
if (dwMask and CFM_OFFSET) <> 0 then Include(Result, caOffset);
if (dwMask and CFM_SPACING) <> 0 then Include(Result, caSpacing);
if (dwMask and CFM_KERNING) <> 0 then Include(Result, caKerning);
if (dwMask and CFM_UNDERLINETYPE) <> 0 then Include(Result, caULType);
if (dwMask and CFM_ANIMATION) <> 0 then Include(Result, caAnimation);
if (dwMask and CFM_SMALLCAPS) <> 0 then Include(Result, caSmallCaps);
if (dwMask and CFM_ALLCAPS) <> 0 then Include(Result, caAllCaps);
if (dwMask and CFM_HIDDEN) <> 0 then Include(Result, caHidden);
if (dwMask and CFM_OUTLINE) <> 0 then Include(Result, caOutline);
if (dwMask and CFM_SHADOW) <> 0 then Include(Result, caShadow);
if (dwMask and CFM_EMBOSS) <> 0 then Include(Result, caEmboss);
if (dwMask and CFM_IMPRINT) <> 0 then Include(Result, caImprint);
if (dwMask and CFM_LINK)<>0 then Include(result, caURL);
end;
end;
end;
procedure TTextAttributes98.GetAttributes(var Format: TCharFormat2W);
begin
InitFormat(Format);
if RichEdit.HandleAllocated then
RichEdit.Perform(EM_GETCHARFORMAT,
WPARAM(FType = atSelected), LPARAM(@Format));
end;
procedure TTextAttributes98.SetAttributes(var Format: TCharFormat2W);
var
Flag: Longint;
begin
if FType = atSelected then
begin
Flag:= SCF_SELECTION or SCF_USEUIRULES;
if (RichEdit.SelLength=0) and RichEdit.WordFormatting then
Flag:= Flag or SCF_WORD;
end
else
Flag:= SCF_DEFAULT;
if RichEdit.HandleAllocated then
RichEdit.Perform(EM_SETCHARFORMAT, Flag, LPARAM(@Format))
end;
procedure TTextAttributes98.Assign(Source: TPersistent);
begin
if Source is TTextAttributes98 then
begin
Color := TTextAttributes98(Source).Color;
Name := TTextAttributes98(Source).Name;
Size:= TTextAttributes98(Source).Size;
Pitch := TTextAttributes98(Source).Pitch;
Weight := TTextAttributes98(Source).Weight;
BackColor := TTextAttributes98(Source).BackColor;
Language := TTextAttributes98(Source).Language;
IndexKind := TTextAttributes98(Source).IndexKind;
Offset := TTextAttributes98(Source).Offset;
Spacing := TTextAttributes98(Source).Spacing;
Kerning := TTextAttributes98(Source).Kerning;
UnderlineType := TTextAttributes98(Source).UnderlineType;
Bold := TTextAttributes98(Source).Bold;
Italic := TTextAttributes98(Source).Italic;
StrikeOut:= TTextAttributes98(Source).StrikeOut;
Animation := TTextAttributes98(Source).Animation;
SmallCaps := TTextAttributes98(Source).SmallCaps;
AllCaps := TTextAttributes98(Source).AllCaps;
Hidden := TTextAttributes98(Source).Hidden;
Outline := TTextAttributes98(Source).Outline;
Shadow := TTextAttributes98(Source).Shadow;
Emboss := TTextAttributes98(Source).Emboss;
Imprint := TTextAttributes98(Source).Imprint;
IsURL:= TTextAttributes98(Source).IsURL;
end
else if Source is TTextAttributes then
begin
Color := TTextAttributes(Source).Color;
Name := TTextAttributes(Source).Name;
Size:= TTextAttributes(Source).Size;
Pitch := TTextAttributes(Source).Pitch;
Bold:= fsBold in TTextAttributes(Source).Style;
Italic:= fsItalic in TTextAttributes(Source).Style;
StrikeOut:= fsStrikeOut in TTextAttributes(Source).Style;
UnderlineType:= TUnderlineType(fsUnderline in TTextAttributes(Source).Style);
end
else if Source is TFont then
begin
Color := TFont(Source).Color;
Name := TFont(Source).Name;
Size:= TFont(Source).Size;
Pitch := TFont(Source).Pitch;
Bold:= fsBold in TFont(Source).Style;
Italic:= fsItalic in TFont(Source).Style;
StrikeOut:= fsStrikeOut in TFont(Source).Style;
UnderlineType:= TUnderlineType(fsUnderline in TFont(Source).Style);
//Tolik
{if TFont(Source).Name = 'GOST' then
Self.RichEdit.Font.Charset := 204;}
//
end
else
inherited Assign(Source);
end;
procedure TTextAttributes98.AssignTo(Dest: TPersistent);
begin
if Dest is TTextAttributes98 then
begin
TTextAttributes98(Dest).Color := Color;
TTextAttributes98(Dest).Name := Name;
TTextAttributes98(Dest).Size := Size;
TTextAttributes98(Dest).Pitch := Pitch;
TTextAttributes98(Dest).Weight := Weight;
TTextAttributes98(Dest).BackColor := BackColor;
TTextAttributes98(Dest).Language := Language;
TTextAttributes98(Dest).IndexKind := IndexKind;
TTextAttributes98(Dest).Offset := Offset;
TTextAttributes98(Dest).Spacing := Spacing;
TTextAttributes98(Dest).Kerning := Kerning;
TTextAttributes98(Dest).UnderlineType := UnderlineType;
TTextAttributes98(Dest).Bold := Bold;
TTextAttributes98(Dest).Italic := Italic;
TTextAttributes98(Dest).Animation := Animation;
TTextAttributes98(Dest).SmallCaps := SmallCaps;
TTextAttributes98(Dest).AllCaps := AllCaps;
TTextAttributes98(Dest).Hidden := Hidden;
TTextAttributes98(Dest).Outline := Outline;
TTextAttributes98(Dest).Shadow := Shadow;
TTextAttributes98(Dest).Emboss := Emboss;
TTextAttributes98(Dest).Imprint := Imprint;
TTextAttributes98(Dest).IsURL := IsURL;
end
else if Dest is TTextAttributes then
begin
TTextAttributes(Dest).Color := Color;
TTextAttributes(Dest).Name := Name;
if Bold then
TTextAttributes(Dest).Style:= [fsBold]
else
TTextAttributes(Dest).Style:= [];
if Italic then
TTextAttributes(Dest).Style:= TTextAttributes(Dest).Style+[fsItalic];
if UnderlineType<>ultNone then
TTextAttributes(Dest).Style:= TTextAttributes(Dest).Style+[fsUnderline];
TTextAttributes(Dest).Charset := CharsetFromLocale(Language);
TTextAttributes(Dest).Size := Size;
TTextAttributes(Dest).Pitch := Pitch;
end
else if Dest is TFont then
begin
TFont(Dest).Color := Color;
TFont(Dest).Name := Name;
if Bold then
TFont(Dest).Style:= [fsBold]
else
TFont(Dest).Style:= [];
if Italic then
TFont(Dest).Style:= TTextAttributes(Dest).Style+[fsItalic];
if UnderlineType<>ultNone then
TFont(Dest).Style:= TTextAttributes(Dest).Style+[fsUnderline];
TFont(Dest).Charset := CharsetFromLocale(Language);
TFont(Dest).Size := Size;
TFont(Dest).Pitch := Pitch;
end
else
inherited AssignTo(Dest);
end;
function TTextAttributes98.GetProtected: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Protected;
Exit;
end;
GetAttributes(Format);
with Format do
if (dwEffects and CFE_PROTECTED) <> 0 then
Result := True else
Result := False;
end;
procedure TTextAttributes98.SetProtected(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Protected:= Value;
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_PROTECTED;
if Value then dwEffects := CFE_PROTECTED;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetColor: TColor;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Color;
Exit;
end;
GetAttributes(Format);
with Format do
if (dwEffects and CFE_AUTOCOLOR) <> 0 then
Result := clWindowText else
Result := crTextColor;
end;
procedure TTextAttributes98.SetColor(Value: TColor);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Color:= Value;
Exit;
end;
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 TTextAttributes98.GetName: TFontName;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Name;
Exit;
end;
GetAttributes(Format);
Result := Format.szFaceName;
end;
procedure TTextAttributes98.SetName(Value: TFontName);
var
Format: TCharFormat2W;
I: Integer;
W: WideString;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Name:= Value;
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_FACE;
W:= Value;
for I:= 0 to Length(Value)-1 do
szFaceName[I]:= W[I+1];
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetPitch: TFontPitch;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Pitch;
Exit;
end;
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 TTextAttributes98.SetPitch(Value: TFontPitch);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Pitch:= Value;
Exit;
end;
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;
function TTextAttributes98.GetSize: Integer;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Size;
Exit;
end;
GetAttributes(Format);
Result := Format.yHeight div 20;
end;
procedure TTextAttributes98.SetSize(Value: Integer);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Size:= Value;
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_SIZE;
yHeight := Value * 20;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetWeight: Word;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
if Bold then
Result:= 700
else
Result:= 400;
Exit;
end;
GetAttributes(Format);
Result := Format.wWeight;
end;
procedure TTextAttributes98.SetWeight(Value: Word);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_Weight;
wWeight := Value;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetBackColor: TColor;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= clNone;
Exit;
end;
GetAttributes(Format);
with Format do
Result := crBackColor;
end;
procedure TTextAttributes98.SetBackColor(Value: TColor);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_BACKCOLOR;
crBackColor := ColorToRGB(Value);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetLanguage: TLanguage;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= 2048;
Exit;
end;
GetAttributes(Format);
Result := Format.lid;
end;
procedure TTextAttributes98.SetLanguage(Value: TLanguage);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_LCID;
lid := Value;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetIndexKind: TIndexKind;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= ikNone;
Exit;
end;
GetAttributes(Format);
case (Format.dwEffects and CFM_SUPERSCRIPT) shr 16 of
0:
Result:= ikNone;
1:
Result:= ikSubscript;
2:
Result:= ikSuperscript;
end;
end;
procedure TTextAttributes98.SetIndexKind(Value: TIndexKind);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_SUPERSCRIPT;
dwEffects := Ord(Value) shl 16;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetOffset: Double;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Format);
Result := Format.yOffset/20;
end;
procedure TTextAttributes98.SetOffset(Value: Double);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_OFFSET;
yOffset := Round(Value*20);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetSpacing: Double;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Format);
Result := Format.sSpacing/20;
end;
procedure TTextAttributes98.SetSpacing(Value: Double);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_SPACING;
sSpacing := Round(Value*20);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetKerning: Double;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Format);
Result := Format.wKerning/20;
end;
procedure TTextAttributes98.SetKerning(Value: Double);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_KERNING;
wKerning := Round(Value*20);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetUnderlineType: TUnderlineType;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= TUnderlineType(fsUnderline in FOldAttr.Style);
Exit;
end;
GetAttributes(Format);
if (Format.dwEffects and Integer(CFE_UNDERLINE)) <>0 then
Result := TUnderlineType(Format.bUnderlineType)
else
Result:= ultNone;
end;
procedure TTextAttributes98.SetUnderlineType(Value: TUnderlineType);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
if Value=ultNone then
FOldAttr.Style:= FOldAttr.Style-[fsUnderline]
else
FOldAttr.Style:= FOldAttr.Style+[fsUnderline];
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_UNDERLINETYPE;
bUnderlineType := Byte(Value);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetAnimation: TAnimationType;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= aniNone;
Exit;
end;
GetAttributes(Format);
Result := TAnimationType(Format.bAnimation);
end;
procedure TTextAttributes98.SetAnimation(Value: TAnimationType);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_ANIMATION;
bAnimation := Byte(Value);
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetBold: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= fsBold in FOldAttr.Style;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_BOLD <>0;
end;
procedure TTextAttributes98.SetBold(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
if Value then
FOldAttr.Style:= FOldAttr.Style+[fsBold]
else
FOldAttr.Style:= FOldAttr.Style-[fsBold];
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_BOLD;
if Value then
dwEffects:= CFE_BOLD;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetItalic: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= fsItalic in FOldAttr.Style;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_ITALIC <>0;
end;
procedure TTextAttributes98.SetItalic(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
if Value then
FOldAttr.Style:= FOldAttr.Style+[fsItalic]
else
FOldAttr.Style:= FOldAttr.Style-[fsItalic];
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_ITALIC;
if Value then
dwEffects:= CFE_ITALIC;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetStrikeOut: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= fsstrikeOut in FOldAttr.Style;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_STRIKEOUT <>0;
end;
procedure TTextAttributes98.SetStrikeOut(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
if Value then
FOldAttr.Style:= FOldAttr.Style+[fsStrikeout]
else
FOldAttr.Style:= FOldAttr.Style-[fsStrikeout];
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_STRIKEOUT;
if Value then
dwEffects:= CFE_STRIKEOUT;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetSmallCaps: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_SMALLCAPS <>0;
end;
procedure TTextAttributes98.SetSmallCaps(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_SMALLCAPS;
if Value then
dwEffects:= CFE_SMALLCAPS;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetAllCaps: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_ALLCAPS <>0;
end;
procedure TTextAttributes98.SetAllCaps(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_ALLCAPS;
if Value then
dwEffects:= CFE_ALLCAPS;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetHidden: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_HIDDEN <>0;
end;
procedure TTextAttributes98.SetHidden(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_HIDDEN;
if Value then
dwEffects:= CFE_HIDDEN;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetOutline: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_OUTLINE <>0;
end;
procedure TTextAttributes98.SetOutline(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_OUTLINE;
if Value then
dwEffects:= CFE_OUTLINE;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetShadow: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_SHADOW <>0;
end;
procedure TTextAttributes98.SetShadow(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_SHADOW;
if Value then
dwEffects:= CFE_SHADOW;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetEmboss: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_EMBOSS <>0;
end;
procedure TTextAttributes98.SetEmboss(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_EMBOSS;
if Value then
dwEffects:= CFE_EMBOSS;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetImprint: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_IMPRINT <>0;
end;
procedure TTextAttributes98.SetImprint(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_IMPRINT;
if Value then
dwEffects:= CFE_IMPRINT;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetIsURL: Boolean;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Format);
Result := Format.dwEffects and CFE_LINK <>0;
end;
procedure TTextAttributes98.SetIsURL(Value: Boolean);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
Exit;
InitFormat(Format);
with Format do
begin
dwMask := CFM_LINK;
if Value then
dwEffects:= CFE_LINK;
end;
SetAttributes(Format);
end;
function TTextAttributes98.GetHeight: Integer;
begin
Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
end;
procedure TTextAttributes98.SetHeight(Value: Integer);
begin
Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
end;
function TTextAttributes98.GetStyle: TFontStyles;
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
Result:= FOldAttr.Style;
Exit;
end;
Result := [];
GetAttributes(Format);
with Format do
begin
if (dwEffects and Integer(CFE_BOLD)) <> 0 then Include(Result, fsBold);
if (dwEffects and Integer(CFE_ITALIC)) <> 0 then Include(Result, fsItalic);
if (dwEffects and Integer(CFE_UNDERLINE)) <> 0 then Include(Result, fsUnderline);
if (dwEffects and Integer(CFE_STRIKEOUT)) <> 0 then Include(Result, fsStrikeOut);
end;
end;
procedure TTextAttributes98.SetStyle(Value: TFontStyles);
var
Format: TCharFormat2W;
begin
if RichEdit.FVer10 then
begin
FOldAttr.Style:= Value;
Exit;
end;
InitFormat(Format);
with Format do
begin
dwMask := CFM_BOLD or CFM_ITALIC or CFM_STRIKEOUT or CFM_UNDERLINETYPE;
if fsBold in Value then dwEffects := dwEffects or CFE_BOLD;
if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC;
if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT;
bUnderlineType:= Ord(fsUnderline in Value);
end;
SetAttributes(Format);
end;
{ TParaAttributes98}
constructor TParaAttributes98.Create(AOwner: TCustomRichEdit98);
begin
inherited Create(AOwner);
RichEdit := AOwner;
end;
procedure TParaAttributes98.InitPara(var Paragraph: TParaFormat2);
begin
FillChar(Paragraph, SizeOf(TParaFormat2), 0);
Paragraph.cbSize := SizeOf(TParaFormat2);
end;
procedure TParaAttributes98.GetAttributes(var Paragraph: TParaFormat2);
begin
InitPara(Paragraph);
if RichEdit.HandleAllocated then
RichEdit.Perform(EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
end;
procedure TParaAttributes98.SetAttributes(var Paragraph: TParaFormat2);
begin
if RichEdit.HandleAllocated then
RichEdit.Perform(EM_SETPARAFORMAT, 0, LPARAM(@Paragraph))
end;
function TParaAttributes98.GetFirstIndent: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TRichEdit(RichEdit).Paragraph.FirstIndent;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dxStartIndent/20;
end;
procedure TParaAttributes98.SetFirstIndent(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.FirstIndent:= Round(Value);
Exit;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_STARTINDENT;
dxStartIndent := Round(Value * 20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetLeftIndent: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TRichEdit(RichEdit).Paragraph.LeftIndent;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dxOffset/20;
end;
procedure TParaAttributes98.SetLeftIndent(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.LeftIndent:= Round(Value);
Exit;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_OFFSET;
dxOffset := Round(Value * 20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetRightIndent: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TRichEdit(RichEdit).Paragraph.RightIndent;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dxRightIndent/20;
end;
procedure TParaAttributes98.SetRightIndent(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.RightIndent:= Round(Value);
Exit;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_RIGHTINDENT;
dxRightIndent := Round(Value * 20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetSpaceBefore: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dySpaceBefore/20;
end;
procedure TParaAttributes98.SetSpaceBefore(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SPACEBEFORE;
dySpaceBefore := Round(Value*20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetSpaceAfter: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dySpaceAfter/20;
end;
procedure TParaAttributes98.SetSpaceAfter(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SPACEAFTER;
dySpaceAfter := Round(Value*20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetLineSpacing: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.dyLineSpacing/20;
end;
function TParaAttributes98.GetLineSpacingRule: TLineSpacingRule;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
GetAttributes(Paragraph);
Result := TLineSpacingRule(Paragraph.bLineSpacingRule);
end;
procedure TParaAttributes98.SetLineSpacing(Rule: TLineSpacingRule; Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_LINESPACING;
bLineSpacingRule:= Ord(Rule);
dyLineSpacing := Round(Value*20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetKeepTogether: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_KEEP <>0;
end;
procedure TParaAttributes98.SetKeepTogether(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_KEEP;
if Value then
wReserved:= PFE_KEEP;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetKeepWithNext: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_KEEPNEXT <>0;
end;
procedure TParaAttributes98.SetKeepWithNext(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_KEEPNEXT;
if Value then
wReserved:= PFE_KEEPNEXT;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetPageBreakBefore: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_PAGEBREAKBEFORE <>0;
end;
procedure TParaAttributes98.SetPageBreakBefore(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_PAGEBREAKBEFORE;
if Value then
wReserved:= PFE_PAGEBREAKBEFORE;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNoLineNumber: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_NOLINENUMBER <>0;
end;
procedure TParaAttributes98.SetNoLineNumber(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NOLINENUMBER;
if Value then
wReserved:= PFE_NOLINENUMBER;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNoWidowControl: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_NOWIDOWCONTROL <>0;
end;
procedure TParaAttributes98.SetNoWidowControl(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NOWIDOWCONTROL;
if Value then
wReserved:= PFE_NOWIDOWCONTROL;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetDoNotHyphen: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_DONOTHYPHEN <>0;
end;
procedure TParaAttributes98.SetDoNotHyphen(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_DONOTHYPHEN;
if Value then
wReserved:= PFE_DONOTHYPHEN;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetSideBySide: Boolean;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= False;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wReserved and PFE_SIDEBYSIDE <>0;
end;
procedure TParaAttributes98.SetSideBySide(Value: Boolean);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SIDEBYSIDE;
if Value then
wReserved:= PFE_SIDEBYSIDE;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetAlignment: TAlignment98;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TAlignment98(TRichEdit(RichEdit).Paragraph.Alignment);
Exit;
end;
GetAttributes(Paragraph);
Result := TAlignment98(Paragraph.wAlignment - 1);
end;
procedure TParaAttributes98.SetAlignment(Value: TAlignment98);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.Alignment:= TAlignment(Value);
Exit;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_ALIGNMENT;
wAlignment := Ord(Value) + 1;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNumbering: TNumberingStyle98;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TNumberingStyle98(TRichEdit(RichEdit).Paragraph.Numbering);
Exit;
end;
GetAttributes(Paragraph);
Result := TNumberingStyle98(Paragraph.wNumbering);
end;
procedure TParaAttributes98.SetNumbering(Value: TNumberingStyle98);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.Numbering:= TNumberingStyle(Value<>nsNone);
Exit;
end;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NUMBERING;
wNumbering := Word(Value);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNumberingStart: Word;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wNumberingStart;
end;
procedure TParaAttributes98.SetNumberingStart(Value: Word);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NUMBERINGSTART;
wNumberingStart := Value;
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNumberingFollow: TNumberingFollow;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= nfPeriod;
Exit;
end;
GetAttributes(Paragraph);
Result := TNumberingFollow(Paragraph.wNumberingStyle);
end;
procedure TParaAttributes98.SetNumberingFollow(Value: TNumberingFollow);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NUMBERINGSTYLE;
wNumberingStyle := Word(Value);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetNumberingTab: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wNumberingTab/20;
end;
procedure TParaAttributes98.SetNumberingTab(Value: Double);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_NUMBERINGTAB;
wNumberingTab := Round(Value*20);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetBorderSpace: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.wBorderSpace/20;
end;
function TParaAttributes98.GetBorderWidth: Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
GetAttributes(Paragraph);
Result := Paragraph.wBorderWidth/20;
end;
function TParaAttributes98.GetBorderLocations: TBorderLocations;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= [];
Exit;
end;
GetAttributes(Paragraph);
Byte(Result) := Lo(Paragraph.wBorders);
end;
function TParaAttributes98.GetBorderStyle: TBorderStyle;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
GetAttributes(Paragraph);
Byte(Result) := Hi(Paragraph.wBorders) and 15;
end;
const
IndexedColors: array[0..15]of TColor=
(clBlack, clBlue, clAqua, clLime, clFuchsia, clRed, clYellow, clWhite,
clNavy, clTeal, clGreen, clPurple, clMaroon, clOlive, clDkGray, clLtGray);
function FindClosestColor(Color: TColor): Byte;
var
I, N, NMin: Byte;
begin
NMin:= 255;
for I:= 0 to 15 do
begin
N:= Abs(TPaletteEntry(Color).peBlue-TPaletteEntry(IndexedColors[I]).peBlue)+
Abs(TPaletteEntry(Color).peGreen-TPaletteEntry(IndexedColors[I]).peGreen)+
Abs(TPaletteEntry(Color).peRed-TPaletteEntry(IndexedColors[I]).peRed);
if N<NMin then
begin
NMin:= N;
Result:= I;
if N=0 then
Exit;
end;
end;
end;
function TParaAttributes98.GetBorderColor: TColor;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= clNone;
Exit;
end;
GetAttributes(Paragraph);
Result:= IndexedColors[Hi(Paragraph.wBorders) shr 4];
end;
procedure TParaAttributes98.SetBorder(Space, Width: Double; Locations: TBorderLocations;
Style: TBorderStyle; Color: TColor);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_BORDER;
wBorderSpace := Round(Space*20);
wBorderWidth := Round(Width*20);
wBorders:= FindClosestColor(Color) shl 12 or Byte(Style) shl 8 or Byte(Locations);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetShadingWeight: TShadingWeight;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= 0;
Exit;
end;
GetAttributes(Paragraph);
Result := TShadingWeight(Paragraph.wShadingWeight);
end;
function TParaAttributes98.GetShadingStyle: TShadingStyle;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
GetAttributes(Paragraph);
Result := TShadingStyle(Paragraph.wShadingStyle and 15);
end;
function TParaAttributes98.GetShadingColor: TColor;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= clNone;
Exit;
end;
GetAttributes(Paragraph);
Result := IndexedColors[(Paragraph.wShadingStyle shr 4) and 15];
end;
function TParaAttributes98.GetShadingBackColor: TColor;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
GetAttributes(Paragraph);
Result := IndexedColors[(Paragraph.wShadingStyle shr 8) and 15];
end;
procedure TParaAttributes98.SetShading(Weight: TShadingWeight; Style: TShadingStyle;
Color, BackColor: TColor);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
Exit;
InitPara(Paragraph);
with Paragraph do
begin
dwMask := PFM_SHADING;
wShadingWeight := Weight;
wShadingStyle:= FindClosestColor(BackColor) shl 8 or
FindClosestColor(Color) shl 4 or Byte(Style);
end;
SetAttributes(Paragraph);
end;
function TParaAttributes98.GetTabCount: Integer;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TRichEdit(RichEdit).Paragraph.TabCount;
Exit;
end;
GetAttributes(Paragraph);
Result := Paragraph.cTabCount;
end;
function TParaAttributes98.GetTab(Index: Integer): Double;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= TRichEdit(RichEdit).Paragraph.Tab[Index];
Exit;
end;
GetAttributes(Paragraph);
Result := (Paragraph.rgxTabs[Index] and $FFFFFF)/20;
end;
function TParaAttributes98.GetTabAlignment(Index: Integer): TTabAlignment;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= tbaLeft;
Exit;
end;
GetAttributes(Paragraph);
Result := TTabAlignment(Paragraph.rgxTabs[Index] shr 24 and 15);
end;
function TParaAttributes98.GetTabLeader(Index: Integer): TTabLeader;
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
Result:= tblNone;
Exit;
end;
GetAttributes(Paragraph);
Result := TTabLeader(Paragraph.rgxTabs[Index] shr 28);
end;
procedure TParaAttributes98.SetTab(Index: Integer; Value: Double;
Alignment: TTabAlignment; Leader: TTabLeader);
var
Paragraph: TParaFormat2;
begin
if RichEdit.FVer10 then
begin
TRichEdit(RichEdit).Paragraph.Tab[Index]:= Round(Value);
Exit;
end;
GetAttributes(Paragraph);
with Paragraph do
begin
rgxTabs[Index] := Round(Value * 20) or (Byte(Alignment) shl 24) or
(Byte(Leader) shl 28);
dwMask := PFM_TABSTOPS;
if cTabCount < Index then cTabCount := Index;
SetAttributes(Paragraph);
end;
end;
{ TRichEditStrings98 }
const
ReadError = $0001;
WriteError = $0002;
NoError = $0000;
ReReadError = $0003;
type
TSelection = record
StartPos, EndPos: Integer;
end;
PRichEditStreamInfo = ^TRichEditStreamInfo;
TRichEditStreamInfo = record
Converter: TConversion;
Stream: TStream;
RichEdit: TCustomRichEdit98;
end;
TRichEditStrings98 = class(TStrings)
private
RichEdit: TCustomRichEdit98;
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;
// function GetPlainText: Boolean;
// procedure SetPlainText(Value: Boolean);
function GetInputFormat: TInputFormat;
procedure SetInputFormat(Value: TInputFormat);
function GetOutputFormat: TOutputFormat;
procedure SetOutputFormat(Value: TOutputFormat);
function GetSelectedInOut:Boolean;
procedure SetSelectedInOut(Value: Boolean);
function GetPlainRTF: Boolean;
procedure SetPlainRTF(Value: Boolean);
public
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 LoadFromStream(Stream: TStream; Encoding: TEncoding); override; // Tolik 05/10/2021 - -
procedure SaveToFile(const FileName: string); override;
procedure SaveToFile(const FileName: string; Encoding: TEncoding); override;
procedure SaveToStream(Stream: TStream); override;
procedure SaveToStream(Stream: TStream; Encoding: TEncoding); override;
// property PlainText: Boolean read GetPlainText write SetPlainText;
property InputFormat: TInputFormat read GetInputFormat write SetInputFormat;
property OutputFormat: TOutputFormat read GetOutputFormat write SetOutputFormat;
property SelectedInOut: Boolean read GetSelectedInOut write SetSelectedInOut;
property PlainRTF:Boolean read GetPlainRTF write SetPlainRTF;
end;
TWideRichEditStrings98 = class(TWideStrings)
private
RichEdit: TCustomRichEdit98;
FConverter: TConversion;
procedure EnableChange(const Value: Boolean);
protected
function Get(Index: Integer): WideString; override;
function GetCount: Integer; override;
procedure Put(Index: Integer; const S: WideString); override;
procedure SetUpdateState(Updating: Boolean); override;
procedure SetTextStr(const Value: WideString); override;
procedure SetLanguage(Value: TLanguage); override;
function GetLanguage: TLanguage; override;
// function GetPlainText: Boolean;
// procedure SetPlainText(Value: Boolean);
function GetInputFormat: TInputFormat;
procedure SetInputFormat(Value: TInputFormat);
function GetOutputFormat: TOutputFormat;
procedure SetOutputFormat(Value: TOutputFormat);
function GetSelectedInOut:Boolean;
procedure SetSelectedInOut(Value: Boolean);
function GetPlainRTF: Boolean;
procedure SetPlainRTF(Value: Boolean);
public
procedure Clear; override;
procedure AddStrings(Strings: TWideStrings); override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: WideString); 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 GetPlainText write SetPlainText;
property InputFormat: TInputFormat read GetInputFormat write SetInputFormat;
property OutputFormat: TOutputFormat read GetOutputFormat write SetOutputFormat;
property SelectedInOut: Boolean read GetSelectedInOut write SetSelectedInOut;
property PlainRTF:Boolean read GetPlainRTF write SetPlainRTF;
end;
procedure TRichEditStrings98.AddStrings(Strings: TStrings);
var
SelChange: TNotifyEvent;
begin
SelChange := RichEdit.OnSelectionChange;
RichEdit.OnSelectionChange := nil;
try
inherited AddStrings(Strings);
finally
RichEdit.OnSelectionChange := SelChange;
end;
end;
function TRichEditStrings98.GetCount: Integer;
begin
Result := RichEdit.Perform(EM_GETLINECOUNT, 0, 0);
if RichEdit.Perform(EM_LINELENGTH,
RichEdit.Perform(EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;
function TRichEditStrings98.Get(Index: Integer): string;
begin
Result:= WideToChar(TWideRichEditStrings98(RichEdit.WideLines).Get(Index), RichEdit.FCP);
end;
procedure TRichEditStrings98.Put(Index: Integer; const S: string);
begin
TWideRichEditStrings98(RichEdit.WideLines).Put(Index, CharToWide(S, RichEdit.FCP));
end;
procedure TRichEditStrings98.Insert(Index: Integer; const S: string);
begin
TWideRichEditStrings98(RichEdit.WideLines).Insert(Index, CharToWide(S, RichEdit.FCP));
end;
procedure TRichEditStrings98.Delete(Index: Integer);
begin
TWideRichEditStrings98(RichEdit.WideLines).Delete(Index);
end;
procedure TRichEditStrings98.Clear;
begin
RichEdit.Clear;
end;
procedure TRichEditStrings98.SetUpdateState(Updating: Boolean);
begin
RichEdit.Perform(WM_SETREDRAW, Ord(not Updating), 0);
if not Updating then begin
RichEdit.Refresh;
RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
end;
end;
procedure TRichEditStrings98.EnableChange(const Value: Boolean);
var
EventMask: Longint;
begin
with RichEdit do
begin
if Value then
EventMask := Perform(EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
else
EventMask := Perform(EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
Perform(EM_SETEVENTMASK, 0, EventMask);
end;
end;
procedure TRichEditStrings98.SetTextStr(const Value: string);
begin
EnableChange(False);
try
inherited SetTextStr(Value);
finally
EnableChange(True);
end;
end;
function TRichEditStrings98.GetInputFormat: TInputFormat;
begin
Result:= RichEdit.InputFormat;
end;
procedure TRichEditStrings98.SetInputFormat(Value: TInputFormat);
begin
RichEdit.InputFormat:= Value;
end;
function TRichEditStrings98.GetOutputFormat: TOutputFormat;
begin
Result:= RichEdit.OutputFormat;
end;
procedure TRichEditStrings98.SetOutputFormat(Value: TOutputFormat);
begin
RichEdit.OutputFormat:= Value;
end;
function TRichEditStrings98.GetSelectedInOut:Boolean;
begin
Result:=RichEdit.SelectedInOut;
end;
procedure TRichEditStrings98.SetSelectedInOut(Value: Boolean);
begin
RichEdit.SelectedInOut:=Value;
end;
function TRichEditStrings98.GetPlainRTF: Boolean;
begin
Result:=RichEdit.PlainRTF;
end;
procedure TRichEditStrings98.SetPlainRTF(Value: Boolean);
begin
RichEdit.PlainRTF:=Value;
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);
if Assigned(StreamInfo^.RichEdit.FOnSaveProgress) then
StreamInfo^.RichEdit.FOnLoadProgress(StreamInfo^.RichEdit,
StreamInfo^.Stream.Position,
StreamInfo^.Stream.Size);
except
Result := WriteError;
end;
end;
}
function StreamSave(dwCookie: Longint; Buffer: TConversionBuffer;
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);
pcb:= StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, Buffer, cb);
if Assigned(StreamInfo^.RichEdit.FOnSaveProgress) then
StreamInfo^.RichEdit.FOnLoadProgress(StreamInfo^.RichEdit,
StreamInfo^.Stream.Position,
StreamInfo^.Stream.Size);
except
Result := WriteError;
end;
end;
{
function StreamLoad(dwCookie: Longint; pbBuff: PChar;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
StreamInfo: PRichEditStreamInfo;
begin
Result := NoError;
StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
pcb:= 0;
try
if Assigned(StreamInfo^.RichEdit.FOnLoadProgress) then
StreamInfo^.RichEdit.FOnLoadProgress(StreamInfo^.RichEdit,
StreamInfo^.Stream.Position,
StreamInfo^.Stream.Size);
if StreamInfo^.Converter <> nil then
pcb:= StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pbBuff, cb);
except
Result := ReadError;
end;
end;
}
function StreamLoad(dwCookie: Longint; Buffer: TConversionBuffer;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
StreamInfo: PRichEditStreamInfo;
begin
Result := NoError;
StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
pcb:= 0;
try
if Assigned(StreamInfo^.RichEdit.FOnLoadProgress) then
StreamInfo^.RichEdit.FOnLoadProgress(StreamInfo^.RichEdit,
StreamInfo^.Stream.Position,
StreamInfo^.Stream.Size);
if StreamInfo^.Converter <> nil then
// pcb:= StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pbBuff, cb);
pcb:= StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, buffer, cb);
except
Result := ReadError;
end;
end;
//
procedure TRichEditStrings98.LoadFromStream(Stream: TStream; Encoding: TEncoding); // Tolik 05/10/2021 - -
var
Convert: PConversionFormat;
begin
Convert := @RTFConversionFormat;
if Convert = nil then
Convert := @TextConversionFormat;
FConverter := Convert^.ConversionClass.Create;
try
LoadFromStream(Stream);
except
FConverter.Free;
FConverter := nil;
raise;
end;
end;
//
procedure TRichEditStrings98.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;
StreamInfo.RichEdit:= RichEdit;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
case InputFormat of
ifText:
TextType:=SF_TEXT;
ifRTF:
TextType:=SF_RTF;
ifUnicode:
TextType:=SF_UNICODE or SF_TEXT;
end;
if SelectedInOut then
TextType:= TextType or SFF_SELECTION;
if PlainRTF then
TextType:= TextType or SFF_PLAINRTF;
RichEdit.Perform(EM_STREAMIN, TextType, Longint(@EditStream));
if ((TextType and SF_RTF)=SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position:= Position;
TextType:= SF_TEXT;
if SelectedInOut then
TextType:= TextType or SFF_SELECTION;
if PlainRTF then
TextType:= TextType or SFF_PLAINRTF;
RichEdit.Perform(EM_STREAMIN, TextType, Longint(@EditStream));
//if EditStream.dwError <> 0 then
// raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then Converter.Free;
if RichEdit.AutoURLDetect=adExtended then
begin
RichEdit.FCROld.cpMin:= 0;
RichEdit.FCROld.cpMax:= GetWindowTextLength(RichEdit.Handle);
RichEdit.DetectURLs(RichEdit.FCROld);
end;
end;
end;
procedure TRichEditStrings98.SaveToStream(Stream: TStream; Encoding: TEncoding);
begin
SaveToStream(Stream);
end;
procedure TRichEditStrings98.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;
StreamInfo.RichEdit:= RichEdit;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamSave;
dwError := 0;
end;
case OutputFormat of
ofText:
TextType:= SF_TEXT;
ofRTF:
TextType:= SF_RTF;
ofRTFNoObjs:
TextType:= SF_RTFNOOBJS;
ofTextized:
TextType:= SF_TEXTIZED;
ofUnicode:
TextType:= SF_TEXT or SF_UNICODE;
end;
if SelectedInOut then TextType:=TextType or SFF_SELECTION;
if PlainRTF then TextType:=TextType or SFF_PLAINRTF;
RichEdit.Perform(EM_STREAMOUT, TextType, Longint(@EditStream));
//if EditStream.dwError <> 0 then
// raise EOutOfResources.Create(sRichEditSaveFail);
finally
if FConverter = nil then Converter.Free;
end;
end;
procedure TRichEditStrings98.LoadFromFile(const FileName: string);
var
Ext: string;
Convert: PConversionFormat;
begin
Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
System.Delete(Ext, 1, 1);
//Convert := ConversionFormatList;
Convert := @RTFConversionFormat;
{
while Convert <> nil do
with Convert^ do
// if Extension <> Ext then Convert := nil//Next
// if Extension <> Ext then Convert := Next
// else Break;
}
if Convert = nil then
Convert := @TextConversionFormat;
FConverter := Convert^.ConversionClass.Create;
try
inherited LoadFromFile(FileName);
except
FConverter.Free;
FConverter := nil;
raise;
end;
end;
procedure TRichEditStrings98.SaveToFile(const FileName: string);
var
Ext: string;
Convert: PConversionFormat;
begin
Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
System.Delete(Ext, 1, 1);
//Convert := ConversionFormatList;
Convert := @RTFConversionFormat;
{
while Convert <> nil do
with Convert^ do
//if Extension <> Ext then Convert := nil//Next
//if Extension <> Ext then Convert := Next
//else Break;
}
if Convert = nil then
Convert := @TextConversionFormat;
FConverter := Convert^.ConversionClass.Create;
try
inherited SaveToFile(FileName, nil);
except
FConverter.Free;
FConverter := nil;
raise;
end;
end;
procedure TRichEditStrings98.SaveToFile(const FileName: string; Encoding: TEncoding);
var
Ext: string;
Convert: PConversionFormat;
begin
Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
System.Delete(Ext, 1, 1);
//Convert := ConversionFormatList;
Convert := @RTFConversionFormat;
{
while Convert <> nil do
with Convert^ do
//if Extension <> Ext then Convert := nil//Next
//if Extension <> Ext then Convert := Next
//else Break;
}
if Convert = nil then
Convert := @TextConversionFormat;
FConverter := Convert^.ConversionClass.Create;
try
inherited SaveToFile(FileName, nil);
except
FConverter.Free;
FConverter := nil;
raise;
end;
end;
procedure TWideRichEditStrings98.AddStrings(Strings: TWideStrings);
var
SelChange: TNotifyEvent;
begin
SelChange := RichEdit.OnSelectionChange;
RichEdit.OnSelectionChange := nil;
try
inherited AddStrings(Strings);
finally
RichEdit.OnSelectionChange := SelChange;
end;
end;
function TWideRichEditStrings98.GetCount: Integer;
begin
Result := RichEdit.Perform(EM_GETLINECOUNT, 0, 0);
if RichEdit.Perform(EM_LINELENGTH,
RichEdit.Perform(EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;
function TWideRichEditStrings98.Get(Index: Integer): WideString;
var
Text: array[0..4095] of WideChar;
L: Integer;
begin
RichEdit.FWide:= True;
Word((@Text)^) := SizeOf(Text);
L := RichEdit.PrivatePerform(EM_GETLINE, Index, Longint(@Text));
if (Text[L - 1] = #13) then Dec(L, 1);
SetString(Result, Text, L);
RichEdit.FWide:= False;
end;
procedure TWideRichEditStrings98.Put(Index: Integer; const S: WideString);
var
Selection: TCharRange;
begin
if Index >= 0 then
begin
RichEdit.FWide:= True;
Selection.cpMin := RichEdit.Perform(EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := Selection.cpMin +
RichEdit.Perform(EM_LINELENGTH, Selection.cpMin, 0);
RichEdit.Perform(EM_EXSETSEL, 0, Longint(@Selection));
RichEdit.PrivatePerform(EM_REPLACESEL, 0, Longint(PChar(S)));
end;
RichEdit.FWide:= False;
end;
end;
procedure TWideRichEditStrings98.Insert(Index: Integer; const S: WideString);
var
L: Integer;
Selection: TCharRange;
Str: WideString;
begin
if Index >= 0 then
begin
RichEdit.FWide:= True;
Selection.cpMin := RichEdit.Perform(EM_LINEINDEX, Index, 0);
if Selection.cpMin >= 0 then
Str:= S+WideString(#13)
else begin
Selection.cpMin :=
RichEdit.Perform(EM_LINEINDEX, Index - 1, 0);
if Selection.cpMin < 0 then Exit;
L := RichEdit.Perform(EM_LINELENGTH, Selection.cpMin, 0);
if L = 0 then Exit;
Inc(Selection.cpMin, L);
Str := WideString(#13)+S;
end;
Selection.cpMax := Selection.cpMin;
RichEdit.Perform(EM_EXSETSEL, 0, Longint(@Selection));
RichEdit.PrivatePerform(EM_REPLACESEL, 0, LongInt(@Str[1]));
if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
raise EOutOfResources.Create(sRichEditInsertError);
RichEdit.FWide:= False;
end;
end;
procedure TWideRichEditStrings98.Delete(Index: Integer);
const
Empty: PWideChar = '';
var
Selection: TCharRange;
begin
if Index < 0 then Exit;
Selection.cpMin := RichEdit.Perform(EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := RichEdit.Perform(EM_LINEINDEX, Index + 1, 0);
if Selection.cpMax = -1 then
Selection.cpMax := Selection.cpMin +
RichEdit.Perform(EM_LINELENGTH, Selection.cpMin, 0);
RichEdit.Perform(EM_EXSETSEL, 0, Longint(@Selection));
RichEdit.PrivatePerform(EM_REPLACESEL, 0, Longint(Empty));
end;
end;
procedure TWideRichEditStrings98.Clear;
begin
RichEdit.Clear;
end;
procedure TWideRichEditStrings98.SetUpdateState(Updating: Boolean);
begin
RichEdit.Perform(WM_SETREDRAW, Ord(not Updating), 0);
if not Updating then begin
RichEdit.Refresh;
RichEdit.PrivatePerform(CM_TEXTCHANGED, 0, 0);
end;
end;
procedure TWideRichEditStrings98.EnableChange(const Value: Boolean);
var
EventMask: Longint;
begin
with RichEdit do
begin
if Value then
EventMask := Perform(EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
else
EventMask := Perform(EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
Perform(EM_SETEVENTMASK, 0, EventMask);
end;
end;
procedure TWideRichEditStrings98.SetTextStr(const Value: WideString);
begin
RichEdit.FWide:= True;
EnableChange(False);
try
inherited SetTextStr(Value);
finally
EnableChange(True);
end;
RichEdit.FWide:= False;
end;
{
function TWideRichEditStrings98.GetPlainText: Boolean;
begin
Result:= RichEdit.PlainText;
end;
procedure TWideRichEditStrings98.SetPlainText(Value: Boolean);
begin
RichEdit.PlainText:= Value;
end;
}
function TWideRichEditStrings98.GetInputFormat: TInputFormat;
begin
Result:= RichEdit.InputFormat;
end;
procedure TWideRichEditStrings98.SetInputFormat(Value: TInputFormat);
begin
RichEdit.InputFormat:= Value;
end;
function TWideRichEditStrings98.GetOutputFormat: TOutputFormat;
begin
Result:= RichEdit.OutputFormat;
end;
procedure TWideRichEditStrings98.SetOutputFormat(Value: TOutputFormat);
begin
RichEdit.OutputFormat:= Value;
end;
function TWideRichEditStrings98.GetSelectedInOut:Boolean;
begin
Result:=RichEdit.SelectedInOut;
end;
procedure TWideRichEditStrings98.SetSelectedInOut(Value: Boolean);
begin
RichEdit.SelectedInOut:=Value;
end;
function TWideRichEditStrings98.GetPlainRTF: Boolean;
begin
Result:=RichEdit.PlainRTF;
end;
procedure TWideRichEditStrings98.SetPlainRTF(Value: Boolean);
begin
RichEdit.PlainRTF:=Value;
end;
procedure TWideRichEditStrings98.LoadFromStream(Stream: TStream);
begin
RichEdit.Lines.LoadFromStream(Stream);
end;
procedure TWideRichEditStrings98.SaveToStream(Stream: TStream);
begin
RichEdit.Lines.SaveToStream(Stream);
end;
procedure TWideRichEditStrings98.LoadFromFile(const FileName: string);
begin
RichEdit.Lines.LoadFromFile(FileName);
end;
procedure TWideRichEditStrings98.SaveToFile(const FileName: string);
begin
RichEdit.Lines.SaveToFile(FileName);
end;
procedure TWideRichEditStrings98.SetLanguage(Value: TLanguage);
begin
RichEdit.Language:= Value;
end;
function TWideRichEditStrings98.GetLanguage: TLanguage;
begin
Result:= RichEdit.Language;
end;
{TURLType}
procedure TURLType.Assign(Source: TPersistent);
begin
if (Source is TURLType) then
begin
Name:= TURLType(Source).Name;
Color:= TURLType(Source).Color;
Cursor:= TURLType(Source).Cursor;
Underline:= TURLType(Source).Underline;
end;
end;
function TURLType.GetDisplayName: string;
begin
Result:= Name;
end;
{TURLCollection}
procedure TURLCollection.AddURLType(const Name: String; Color: TColor;
Cursor: TCursor; Underline: Boolean);
var
Item: TURLType;
I: INteger;
begin
for I:= 0 to Count-1 do
begin
Item:= Items[I];
if Item.Name=Name then
begin
Item.Color:= Color;
Item.Cursor:= Cursor;
Item.Underline:= Underline;
Exit;
end;
end;
Item:= TURLType(Add);
Item.Name:= Name;
Item.Color:= Color;
Item.Cursor:= Cursor;
Item.Underline:= Underline;
end;
function TURLCollection.GetOwner: TPersistent;
begin
Result:= FOwner;
end;
procedure TURLCollection.SetItems(Index: Integer; Value: TURLType);
begin
if (Index>-1) and (Index<Count) then
Items[Index].Assign(Value);
end;
function TURLCollection.GetItems(Index: Integer): TURLType;
begin
Result:= TURLType(inherited Items[Index]);
end;
{ TCustomRichEdit98 }
constructor TCustomRichEdit98.Create(AOwner: TComponent);
var
DC: HDC;
begin
FUpdateCount:= 0;
FShowSelBar:= False;
FLangOptions:= [loAutoFont];
inherited Create(AOwner);
FSelAttributes := TTextAttributes98.Create(Self, atSelected);
FDefAttributes := TTextAttributes98.Create(Self, atDefaultText);
FParagraph := TParaAttributes98.Create(Self);
FRichEditStrings:= TRichEditStrings98.Create;
TRichEditStrings98(FRichEditStrings).RichEdit := Self;
FWideStrings := TWideRichEditStrings98.Create;
TWideRichEditStrings98(FWideStrings).RichEdit := Self;
DC := GetDC(0);
FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
ReleaseDC(0, DC);
FWide:= False;
FWordFormatting:= True;
Language:= GetSystemDefaultLCID;
FURLs:= TURLCollection.Create(TURLType);
FURLs.FOwner:= Self;
FURLs.AddURLType('e-mail', clWindowText, crDefault, True);
FURLs.AddURLType('http', clWindowText, crDefault, True);
FURLs.AddURLType('file', clWindowText, crDefault, True);
FURLs.AddURLType('mailto', clWindowText, crDefault, True);
FURLs.AddURLType('ftp', clWindowText, crDefault, True);
FURLs.AddURLType('https', clWindowText, crDefault, True);
FURLs.AddURLType('gopher', clWindowText, crDefault, True);
FURLs.AddURLType('nntp', clWindowText, crDefault, True);
FURLs.AddURLType('prospero', clWindowText, crDefault, True);
FURLs.AddURLType('telnet', clWindowText, crDefault, True);
FURLs.AddURLType('news', clWindowText, crDefault, True);
FURLs.AddURLType('wais', clWindowText, crDefault, True);
FURLColor:= clBlue;
FURLCursor:= crHandpoint;
FStreamSel:= False;
FCROld.cpMin:= 0;
FCROld.cpMax:= 0;
FAutoVerbMenu:= true;
FPlainTextIn:= ifRTF;
FPlainTextOut:= ofRTF;
FPlainRTF:= False;
FSelectedInOut:= False;
FIncludeOLE:= False;
end;
destructor TCustomRichEdit98.Destroy;
begin
FSelAttributes.Free;
FDefAttributes.Free;
FParagraph.Free;
FRichEditStrings.Free;
FWideStrings.Free;
FURLs.Free;
DestroyVerbs;
inherited Destroy;
end;
function TCustomRichEdit98.ObjectSelected:Boolean;
var ReObject:TReObject;
begin
ReObject.cbStruct:= sizeof(TReObject);
result:=(RichEditOle.GetObject(REO_IOB_SELECTION, ReObject, REO_GETOBJ_POLEOBJ) = S_OK) and
Assigned(ReObject.oleobj);
end;
procedure TCustomRichEdit98.CreateParams(var Params: TCreateParams);
const
RichEditModuleName = 'RICHED20.DLL';
ControlClassName = 'RICHEDIT20W';
CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
CS_ON = CS_VREDRAW or CS_HREDRAW;
var
OldError: Longint;
SaveInstance: THandle;
WCW: TWndClassW;
WCA: TWndClassA;
begin
OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
FLibHandle := LoadLibrary(RichEditModuleName);
FVer10:= False;
if (FLibHandle > 0) and (FLibHandle < HINSTANCE_ERROR) then
FLibHandle := 0;
if FLibHandle=0 then
begin
FVer10:= True;
IsWinNT:= False;
inherited CreateParams(Params);
Exit;
end;
SetErrorMode(OldError);
if IsWinNT then
begin
GetClassInfoW(HInstance, ControlClassName, WCW);
FDefWndProcW:= WCW.lpfnWndProc;
end
else
GetClassInfoA(HInstance, ControlClassName, WCA);
FDefWndProcA:= WCA.lpfnWndProc;
inherited CreateParams(Params);
// Params.Style:= Params.Style or ES_SAVESEL;
Params.Style:= Params.Style or WS_CHILD or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ES_SAVESEL;
CreateSubClass(Params, ControlClassName);
end;
procedure TCustomRichEdit98.CreateWnd;
var
Opt: Integer;
begin
inherited CreateWnd;
SendMessage(Handle, EM_SETEVENTMASK, 0,
ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
ENM_PROTECTED or ENM_LINK);
SendMessage(Handle, EM_AUTOURLDETECT, Ord(AutoURLDetect=adDefault), 0);
Opt:= Perform(EM_GETOPTIONS, 0, 0);
if FShowSelBar then
Opt:= Opt or ECO_SELECTIONBAR
else
Opt:= Opt and not ECO_SELECTIONBAR;
Perform(EM_SETOPTIONS, ECOOP_SET, Opt);
SetShowSelBar(FShowSelBar);
Perform(EM_SETLANGOPTIONS, 0, Byte(FLangOptions));
if FIncludeOLE then
begin
if not RichEdit_GetOleInterface(Handle, RichEditOle) then
raise Exception.Create('Unable to get interface');
if not RichEdit_SetOleCallback(Handle, RichEditOlecallback) then
raise Exception.Create('Unable to set callback');
end;
end;
procedure TCustomRichEdit98.CreateWindowHandle(const Params: TCreateParams);
var
WCN: WideString;
P: TCreateParams;
begin
if IsWinNT then
with Params do
begin
WCN:= WinClassName;
//WindowHandle:= CreateWindowExW(ExStyle , @WCN[1], nil, Style,
WindowHandle:= CreateWindowExW(ExStyle or WS_EX_TRANSPARENT, @WCN[1], nil, Style,
X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);
end
else
begin
Move(Params, P, SizeOf(Params));
P.Caption:= nil;
inherited CreateWindowHandle(P);
end;
end;
procedure TCustomRichEdit98.CreateOLEObjectInterface;
begin
RichEditOleCallback := TRichEditOleCallback.Create(Self);
end;
(*{procedure TCustomRichEdit98.CloseOLEObjects; {!!0.01 -- added method}
var i: integer;
REObject: TREObject;
begin
if not Assigned(RichEditOle) then Exit;
fillchar(REObject, sizeof(REObject), 0);
REObject.cbStruct:= sizeof(REObject);
for i:= 0 to Pred(RichEditOle.GetObjectCount) do begin
if RichEditOle.GetObject(i, REObject, REO_GETOBJ_POLEOBJ) = S_OK then
REObject.oleobj.Close(OLECLOSE_NOSAVE);
end;
end;*)
procedure TCustomRichEdit98.CloseOLEObjects; {!!0.01 -- added method}
var
I, ObjCount: Integer;
ReObject: TReObject;
begin
if not Assigned(RichEditOle) then Exit;
if FSelObject<>nil then
begin
FSelObject.Close(OLECLOSE_NOSAVE); /// very important
FSelObject:= nil;
end;
FillChar(ReObject, SizeOf(ReObject), 0);
ReObject.cbStruct := SizeOf(ReObject);
ObjCount := RichEditOle.GetObjectCount;
for I := 1 to RicheditOle.GetObjectCount do
if RichEditOle.GetObject(I, ReObject, REO_GETOBJ_POLEOBJ) = S_OK then
ReObject.oleobj.CLOSE(OLECLOSE_NOSAVE);
end;
procedure TCustomRichEdit98.WMNCDestroy(var Message: TWMNCDestroy);
begin
inherited;
if FLibHandle <> 0 then FreeLibrary(FLibHandle);
end;
procedure TCustomRichEdit98.WMDestroy(var Msg: TMessage); {!!0.01 -- changed from WM_NCDESTROY}
begin
CloseOLEObjects; {!!0.01}
RichEditOle:= nil;
inherited;
end;
procedure TCustomRichEdit98.EMReplaceSel(var Message: TMessage);
var
W: WideString;
begin
if not FWide then
begin
W:= CharToWide(PChar(Message.LParam), FCP);
Message.LParam:= Integer(@W[1]);
end;
Message.WParam:= 1;
Message.Result:= PrivatePerform(Message.Msg, Message.WParam, Message.LParam);
end;
procedure TCustomRichEdit98.EMGetSelText(var Message: TMessage);
var
W: WideString;
S: String;
P: PAnsiChar;
L: Integer;
begin
if SelLength=0 then
begin
Message.Result:= 0;
Exit;
end;
if not FWide then
begin
P:= PAnsiChar(Message.LParam);
L:= SelLength;
SetLength(W, L);
Message.LParam:= Integer(@W[1]);
end;
Message.Result:= PrivatePerform(Message.Msg, Message.WParam, Message.LParam);
if not FWide then
begin
WideCharToMultiByte(FCP, 0, @W[1], -1, P, L, nil, nil);
Message.LParam:= Integer(P);
end;
end;
procedure TCustomRichEdit98.EMGetTextRange(var Message: TMessage);
var
W: WideString;
P: PAnsiChar;
type
PTextRange = ^TTextRange;
begin
if not FWide then
with PTextRange(Message.LParam)^ do
begin
P:= lpstrText;
SetLength(W, Abs(chrg.cpMax - chrg.cpMin));
lpstrText:= PAnsiChar(@W[1]);
end;
Message.Result:= PrivatePerform(Message.Msg, Message.WParam, Message.LParam);
if not FWide then
with PTextRange(Message.LParam)^ do
begin
StrPCopy(P, WideToChar(W, FCP));
lpstrText:= P;
end;
end;
procedure TCustomRichEdit98.Clear; {!!0.01 -- overriden to close objects}
begin
CloseOLEObjects;
inherited Clear;
end;
const
URLChars = ['0'..'9', 'A'..'Z', 'a'..'z', ':', '.', '/', '\', '@'];
procedure TCustomRichEdit98.FindNonSpace(var CR: TCharRange);
var
TRS: TTextRange;
C: packed array[0..1]of Char;
L: Integer;
begin
L:= GetWindowTextLength(Handle);
if CR.cpMin>=L then
CR.cpMin:= L-1;
TRS.chrg.cpMin:= CR.cpMin;
TRS.chrg.cpMax:= CR.cpMin+1;
TRS.lpstrText:= @C[0];
while (TRS.chrg.cpMin>0) do
begin
Perform(EM_GETTEXTRANGE, 0, Integer(@TRS));
if not (C[0] in URLChars) then
Break;
Dec(TRS.chrg.cpMin);
Dec(TRS.chrg.cpMax);
end;
CR.cpMin:= TRS.chrg.cpMin;
Perform(EM_GETTEXTRANGE, 0, Integer(@TRS));
if not (C[0] in URLChars) then
Inc(CR.cpMin);
if CR.cpMax>=L then
Exit;
TRS.chrg.cpMin:= CR.cpMax;
TRS.chrg.cpMax:= CR.cpMax+1;
C:= '.';
while (TRS.chrg.cpMin<=L) and (C[0] in URLChars) do
begin
Perform(EM_GETTEXTRANGE, 0, Integer(@TRS));
Inc(TRS.chrg.cpMin);
Inc(TRS.chrg.cpMax);
end;
CR.cpMax:= TRS.chrg.cpMin-1;
end;
procedure TCustomRichEdit98.DetectURLs(CR: TCharRange);
var
P1, P2: Integer;
Word: String;
I, N: Integer;
URL, S: String;
TR: TTextRange;
OC,
OSC: TNotifyEvent;
Start: Integer;
B: Boolean;
URLType: TURLType;
FW: Boolean;
begin
FW:= FWide;
FWide:= False;
TR.chrg:= CR;
FindNonSpace(TR.chrg);
if (TR.chrg.cpMin>TR.chrg.cpMax) or (GetWindowTextLength(Handle)<3) then
Exit;
BeginUpdate;
if TR.chrg.cpMin=TR.chrg.cpMax then
S:= WideText
else
begin
SetLength(S, TR.chrg.cpMax-TR.chrg.cpMin);
TR.lpstrText:= @S[1];
Perform(EM_GETTEXTRANGE, 0, Integer(@TR));
end;
FWide:= FW;
S:= AnsiUpperCase(S);
OC:= OnChange;
OSC:= OnSelectionChange;
OnChange:= nil;
OnSelectionChange:= nil;
Start:= TR.chrg.cpMin;
P1:= 1;
repeat
P2:= P1;
repeat
Inc(P2)
until not (S[P2] in URLChars);
Word:= Copy(S, P1, P2-P1);
I:= 1;
repeat
URLType:= FURLs[I];
URL:= AnsiUpperCase(URLType.Name+':');
B:= (AnsiPos(URL, Word)=1) and (Length(Word)>Length(URL));
Inc(I);
until (I=FURLs.Count) or B;
if not B then
begin
N:= AnsiPos('@', Word);
B:= (N>1) and (N<Length(Word)) and (AnsiPos('.', Copy(Word, N+1, MaxInt))>1);
URLType:= FURLs[0];
end;
CR.cpMin:= Start+P1-1;
CR.cpMax:= Start+P2-1;
Perform(EM_EXSETSEL, 0, Integer(@CR));
if B then
begin
SelAttributes.IsURL:= True;
if URLType.Color=clWindowText then
SelAttributes.Color:= URLColor
else
SelAttributes.Color:= URLType.Color;
SelAttributes.UnderlineType:= TUnderlineType(URLType.Underline);
end
else
begin
SelAttributes.IsURL:= False;
SelAttributes.Color:= clDefault;
SelAttributes.UnderlineType:= ultNone;
end;
P1:= P2;
if S[P1]=#0 then
Break;
repeat
Inc(P1);
until S[P1] in URLChars+[#0];
until S[P1] in [#0..' '];
EndUpdate;
OnChange:= OC;
OnSelectionChange:= OSC;
end;
procedure TCustomRichEdit98.EMGetLine(var Message: TMessage);
var
W: WideString;
P: PChar;
L: ^Word;
begin
if not FWide then
begin
P:= PChar(Message.LParam);
L:= Pointer(P);
SetLength(W, L^);
Message.LParam:= Integer(@W[1]);
W[1]:= WideChar(L^);
end;
Message.Result:= PrivatePerform(Message.Msg, Message.WParam, Message.LParam);
if not FWide then
begin
StrPCopy(P, WideToChar(W, FCP));
Message.LParam:= Integer(P);
end;
end;
procedure TCustomRichEdit98.EMStreamIn(var Message: TMessage);
begin
if FStreamSel then
Message.WParam:= Message.WParam or SFF_SELECTION;
inherited;
end;
procedure TCustomRichEdit98.EMStreamOut(var Message: TMessage);
begin
if FStreamSel then
Message.WParam:= Message.WParam or SFF_SELECTION;
inherited;
end;
procedure TCustomRichEdit98.WMSetText(var Message: TWMSetText);
var
W: WideString;
begin
if (csDesigning in ComponentState) then
Message.Text:= nil
else if not FWide then
begin
W:= CharToWide(Message.Text, FCP);
if W<>'' then
Message.Text:= @W[1];
end;
Message.Result:= PrivatePerform(Message.Msg, Message.Unused, Integer(Message.Text));
end;
procedure TCustomRichEdit98.WMGetTextLength(var Message: TWMGetTextLength);
var
GTL: TGetTextLengthEx;
begin
GTL.flags:= GTL_DEFAULT;
GTL.codepage:= 1200;
Message.Result:= Perform(EM_GETTEXTLENGTHEX, Integer(@GTL), 0);
end;
procedure TCustomRichEdit98.WMGetText(var Message: TWMGetText);
var
W: WideString;
P: PChar;
L: Integer;
begin
if FWide then
begin
P:= Message.Text;
L:= Perform(WM_GETTEXTLENGTH, 0, 0);
SetLength(W, L);
Message.Text:= @W[1];
GetWindowTextW(Handle, @W[1], L);
StrPCopy(P, WideToChar(W, FCP));
Message.Text:= P;
end
else
inherited;
end;
procedure TCustomRichEdit98.WMSetFont(var Message: TWMSetFont);
begin
FDefAttributes.Assign(Font);
end;
procedure TCustomRichEdit98.CNCommand(var Message: TWMCommand);
var
CR, CRMax: TCharRange;
begin
if not (csLoading in ComponentState) and not (csReading in ComponentState) and
(AutoURLDetect=adExtended) and (FURLs.Count>0) and (Message.NotifyCode = EN_CHANGE) and
(FUpdateCount=0) then
begin
Perform(EM_EXGETSEL, 0, Integer(@CR));
CRMax:= CR;
if FCROld.cpMin<CR.cpMin then
CRMax.cpMin:= FCROld.cpMin;
if FCROld.cpMax>CR.cpMax then
CRMax.cpMax:= FCROld.cpMax;
DetectURLs(CRMax);
FCROld:= CR;
end;
inherited;
end;
procedure TCustomRichEdit98.CNNotify(var Message: TWMNotify);
type
PENLink = ^TENLink;
var
URL: String;
TR: TTextRange;
P: Integer;
URLType: TURLType;
I: Integer;
Cr: TCursor;
begin
case Message.NMHdr^.code of
EN_LINK:
with PENLink(Pointer(Message.NMHdr))^ do
begin
FWide:= False;
URL:= WideText;
URL:= Copy(URL, chrg.cpMin + 1, chrg.cpMax - chrg.cpMin {+ 1});
P:= Pos(':', URL);
if P>1 then
for I:= 1 to FURLs.Count-1 do
begin
URLType:= FURLs[I];
if URLType.Name=AnsiLowerCase(Copy(URL, 1, P-1)) then
Break;
end
else if Pos('@', URL)>1 then
URLType:= FURLs[0];
case msg of
WM_LBUTTONUP:
if Assigned(FOnURLClick) and (Length(URL)>1) then
FOnURLClick(Self, URL);
WM_MOUSEMOVE:
begin
if URLType.Cursor=crDefault then
if URLCursor=crDefault then
CR:= crHandPoint
else
CR:= URLCursor
else
Cr:= URLType.Cursor;
Windows.SetCursor(Screen.Cursors[Cr]);
if Assigned(FOnURLMove) and (Length(URL)>1) then
FOnURLMove(Self, URL);
end;
end;
end;
else
inherited;
end;
end;
procedure TCustomRichEdit98.SetRichEditStrings(Value: TStrings);
begin
FRichEditStrings.Assign(Value);
end;
procedure TCustomRichEdit98.SetSelAttributes(Value: TTextAttributes98);
begin
SelAttributes.Assign(Value);
{ if SelAttributes.Name = 'GOST' then
Font.Charset := 204;}
end;
procedure TCustomRichEdit98.SetDefAttributes(Value: TTextAttributes98);
begin
DefAttributes.Assign(Value);
end;
function TCustomRichEdit98.GetLine: Integer;
begin
Result:= Perform(EM_EXLINEFROMCHAR, 0, -1);
end;
procedure TCustomRichEdit98.SetLine(Value: Integer);
begin
SetCaret(Value, Col);
end;
function TCustomRichEdit98.GetColumn: Integer;
begin
Result:= SelStart - Perform(EM_LINEINDEX, -1, 0);
end;
procedure TCustomRichEdit98.SetColumn(Value: Integer);
begin
SetCaret(Line, Value);
end;
procedure TCustomRichEdit98.SetCaret(Line, Column: Integer);
var
L: Integer;
begin
L:= Perform(EM_LINEINDEX, Line, 0);
if L<0 then
Exit;
SelStart:= L+Column;
end;
procedure TCustomRichEdit98.SetShowSelBar(Value: Boolean);
var
Opt: Integer;
begin
if FShowSelBar<>Value then
begin
FShowSelBar:= Value;
Opt:= Perform(EM_GETOPTIONS, 0, 0);
if Value then
Opt:= Opt or ECO_SELECTIONBAR
else
Opt:= Opt and not ECO_SELECTIONBAR;
RecreateWnd;
Perform(EM_SETOPTIONS, ECOOP_SET, Opt);
end;
end;
function TCustomRichEdit98.CanUndo: Boolean;
begin
Result:= Perform(EM_CANUNDO, 0, 0)<>0;
end;
procedure TCustomRichEdit98.Undo;
begin
Perform(EM_UNDO, 0, 0);
end;
function TCustomRichEdit98.UndoName: TUndoName;
begin
Result:= TUndoName(Perform(EM_GETUNDONAME, 0, 0));
end;
function TCustomRichEdit98.CanRedo: Boolean;
begin
Result:= Perform(EM_CANREDO, 0, 0)<>0;
end;
procedure TCustomRichEdit98.Redo;
begin
Perform(EM_REDO, 0, 0);
end;
function TCustomRichEdit98.RedoName: TUndoName;
begin
Result:= TUndoName(Perform(EM_GETREDONAME, 0, 0));
end;
procedure TCustomRichEdit98.SetUndoLimit(Value: Integer);
begin
FUndoLimit:= Value;
Perform(EM_SETUNDOLIMIT, Value, 0);
end;
procedure TCustomRichEdit98.SetAutoURLDetect(Value: TAutoURLDetect);
begin
FAutoURLDetect:= Value;
Perform(EM_AUTOURLDETECT, Ord(Value=adDefault), 0)
end;
function TCustomRichEdit98.GetFirstVisibleLine: Integer;
begin
Result:= Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
end;
procedure TCustomRichEdit98.SetLanguage(Value: Tlanguage);
begin
FLanguage:= Value;
FCP:= CodePageFromLocale(Value);
end;
procedure TCustomRichEdit98.CMFontChanged(var Message: TMessage);
begin
FDefAttributes.Assign(Font);
end;
function TCustomRichEdit98.GetWordAtPos(Pos: Integer; var Start, Len: Integer): AnsiString;
var
TR: TTextRange;
begin
Start:= Perform(EM_FINDWORDBREAK, WB_LEFT, Pos);
Len:= Perform(EM_FINDWORDBREAK, WB_RIGHTBREAK, Pos) - Start;
TR.chrg.cpMin:= Start;
TR.chrg.cpMax:= Start+Len;
TR.lpstrText:= PAnsiChar(AllocMem(Len + 1));
Perform(EM_GETTEXTRANGE, 0, LParam(@TR));
SetString(Result, TR.lpstrText, Len);
FreeMem(TR.lpstrText);
end;
procedure TCustomRichEdit98.SetCustomURLs(Value: TURLCollection);
var
I: Integer;
Item: TURLType;
begin
FURLS.Clear;
if Assigned(Value) then
for I:= 0 to Value.Count-1 do
begin
Item:= Value[I];
with Item do
FURLs.AddURLType(Name, Color, Cursor, Underline);
end;
end;
procedure TCustomRichEdit98.DefineProperties(Filer: TFiler);
begin
Filer.DefineProperty('RTF', ReadData, WriteData, Perform(WM_GETTEXTLENGTH, 0, 0)>0);
end;
procedure TCustomRichEdit98.ReadData(Reader: TReader);
var
MS: TMemoryStream;
S: String;
OSC,
OC: TNotifyEvent;
begin
try
OSC:= OnSelectionChange;
OC:= OnChange;
OnSelectionChange:= nil;
OnChange:= nil;
Clear;
DefAttributes.Assign(Font);
MS:= TMemoryStream.Create;
S:= Reader.ReadString;
MS.Write(S[1], Length(S));
MS.Position:= 0;
Lines.LoadFromStream(MS);
finally
MS.Free;
OnSelectionChange:= OSC;
OnChange:= OC;
end;
end;
procedure TCustomRichEdit98.WriteData(Writer: TWriter);
var
MS: TMemoryStream;
C: Char;
begin
if Perform(WM_GETTEXTLENGTH, 0, 0)=0 then
Exit;
MS:= TMemoryStream.Create;
Lines.SaveToStream(MS);
C:= #0;
MS.Write(C, 1);
Writer.WriteString(PChar(MS.Memory));
MS.Free;
end;
procedure TCustomRichEdit98.SetWideText(Value: WideString);
begin
FWide:= True;
// SetWindowTextW(Handle, @Value[1]);
SendMessage(Handle, WM_SETTEXT, 0, Integer(@Value[1]));
FWide:= False;
end;
function TCustomRichEdit98.GetWideText: WideString;
var
GTL: TGetTextLengthEx;
GT: TGetTextEx;
L: Integer;
begin
GTL.flags:= GTL_DEFAULT;
GTL.codepage:= 1200;
L:= Perform(EM_GETTEXTLENGTHEX, Integer(@GTL), 0);
SetLength(Result, L);
GT.cb:= L*2+2;
GT.flags:= GT_DEFAULT;
GT.codepage:= 1200;
GT.lpDefaultChar:= nil;
GT.lpUsedDefChar:= nil;
PrivatePerform(EM_GETTEXTEX, Integer(@GT), Integer(@Result[1]));
end;
procedure TCustomRichEdit98.SetRTFSelText(Value: String);
var
MS: TMemoryStream;
OldFormat: TInputFormat;
begin
MS:= TMemoryStream.Create;
MS.Write(Value[1], Length(Value)+1);
MS.Position:= 0;
FStreamSel:= True;
OldFormat:= InputFormat;
InputFormat:= ifRTF;
Lines.LoadFromStream(MS);
InputFormat:= OldFormat;
FStreamSel:= False;
MS.Free;
end;
function TCustomRichEdit98.GetRTFSelText: String;
var
MS: TMemoryStream;
OldFormat: TOutputFormat;
begin
MS:= TMemoryStream.Create;
FStreamSel:= True;
OldFormat:= OutputFormat;
OutputFormat:= ofRTF;
Lines.SaveToStream(MS);
OutputFormat:= OldFormat;
FStreamSel:= False;
Result:= PChar(MS.Memory);
MS.Free;
end;
procedure TCustomRichEdit98.InsertFromFile(const FileName: String);
begin
FStreamSel:= True;
Lines.LoadFromFile(FileName);
FStreamSel:= False;
end;
function TCustomRichEdit98.GetWideSelText: WideString;
var
Length: Integer;
begin
FWide:= True;
SetLength(Result, SelLength + 1);
Length := Perform(EM_GETSELTEXT, 0, Longint(@Result[1]));
SetLength(Result, Length);
FWide:= False;
end;
procedure TCustomRichEdit98.SetWideSelText(Value: WideString);
begin
FWide:= True;
Perform(EM_REPLACESEL, 1, Integer(@Value[1]));
FWide:= False;
end;
function TCustomRichEdit98.FindText(const SearchStr: string;
StartPos, Length: Integer; Options: TSearchTypes98): Integer;
var
Find: TFindTextExW;
Flags: Integer;
W: WideString;
begin
with Find.chrg do
begin
cpMin := StartPos;
if Length>0 then
if stBackward in Options then
cpMax:= cpMin - Length
else
cpMax := cpMin + Length
else
cpMax:= -1;
end;
Flags := FT_DOWNWARD;
if stBackward in Options then Flags := Flags and not FT_DOWNWARD;
if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
W:= CharToWide(SearchStr, FCP);
Find.lpstrText := @W[1];
Result := SendMessage(Handle, EM_FINDTEXTEX, Flags, LongInt(@Find));
end;
function TCustomRichEdit98.FindWideText(const SearchStr: WideString;
StartPos, Length: Integer; Options: TSearchTypes98): Integer;
var
Find: TFindTextExW;
Flags: Integer;
begin
with Find.chrg do
begin
cpMin := StartPos;
if Length>0 then
if stBackward in Options then
cpMax:= cpMin - Length
else
cpMax := cpMin + Length
else
cpMax:= -1;
end;
Flags := FT_DOWNWARD;
if stBackward in Options then Flags := Flags and not FT_DOWNWARD;
if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
Find.lpstrText := @SearchStr[1];
Result := SendMessage(Handle, EM_FINDTEXTEX, Flags, LongInt(@Find));
end;
procedure TCustomRichEdit98.SetLangOptions(Value: TLangOptions);
var
LO: Byte;
begin
FLangOptions:= Value;
Lo:= Byte(Value);
Perform(EM_SETLANGOPTIONS, 0, LO);
end;
function TCustomRichEdit98.PrivatePerform(Msg: Cardinal; WParam, LParam: Longint): Longint;
begin
if HandleAllocated then
if IsWinNT {and FWide }then
Result:= CallWindowProcW(FDefWndProcW, Handle, Msg, Wparam, Lparam)
else
Result:= CallWindowProcA(FDefWndProcA, Handle, Msg, Wparam, Lparam)
end;
procedure TCustomRichEdit98.BeginUpdate;
begin
Inc(FUpdateCount);
Perform(WM_SETREDRAW, 0, 0);
FStoreSS:= SelStart;
FStoreSL:= SelLength;
FStoreFVL:= FirstVisibleLine;
end;
procedure TCustomRichEdit98.EndUpdate;
begin
if FUpdateCount>0 then
Dec(FUpdateCount);
if FUpdateCount=0 then
begin
SelStart:= FStoreSS;
SelLength:= FStoreSL;
while FirstVisibleLine<>FStoreFVL do
if FirstVisibleLine<FStoreFVL then
Perform(EM_SCROLL, SB_LINEDOWN, 0)
else
Perform(EM_SCROLL, SB_LINEUP, 0);
Perform(WM_SETREDRAW, 1, 0);
Repaint;
end;
end;
procedure TCustomRichEdit98.WMPaint(var Message: TWMPaint);
begin
if FUpdateCount=0 then
inherited
else
Message.Result:= 0;
end;
function TCustomRichEdit98.CharAtPos(Pos: TPoint): Integer;
begin
Result:= Perform(EM_CHARFROMPOS, 0, Integer(@Pos));
end;
procedure TCustomRichEdit98.SetIncludeOLE(Value:Boolean);
begin
FIncludeOLE := Value;
if Value then CreateOLEObjectInterface;
ReCreateWnd;
end;
function TCustomRichEdit98.GetPopupMenu: TPopupMenu;
var
I: Integer;
Item: TMenuItem;
ReObject: TReObject;
begin
Result := inherited GetPopupMenu;
if FAutoVerbMenu and Assigned(RichEditOle) then begin
ReObject.cbStruct:= sizeof(TReObject);
{if an object is selected, get its IOLEObject interface}
if (RichEditOle.GetObject(REO_IOB_SELECTION, ReObject, REO_GETOBJ_POLEOBJ) <> S_OK) or
not Assigned(ReObject.oleobj) then begin
{no object selected -- clean up any previous object info}
FSelObject:= nil;
DestroyVerbs;
end
else
if FSelObject = ReObject.oleobj then
{same object selected -- use already allocated menu}
Result:= FPopupVerbMenu
// if Result=nil then begin
else begin
{new object selected -- create a menu for it}
FSelObject:= ReObject.oleobj;
UpdateVerbs;
if FObjectVerbs.Count = 0 then
Result:= nil
else begin
FPopupVerbMenu:= TPopupMenu.Create(Self);
for I := 0 to FObjectVerbs.Count - 1 do begin
Item := TMenuItem.Create(Self);
Item.Caption := FObjectVerbs[I];
Item.Tag := I;
if TVerbInfo(FObjectVerbs.Objects[i]).Verb = 0 then
Item.Default:= true; // Verb = 0 is the primary verb
Item.OnClick := PopupVerbMenuClick;
FPopupVerbMenu.Items.Add(Item);
end;
Result := FPopupVerbMenu;
end;
end;
end;
end;
procedure TCustomRichEdit98.DestroyVerbs;
begin
FPopupVerbMenu.Free;
FPopupVerbMenu := nil;
FObjectVerbs.Free;
FObjectVerbs := nil;
end;
procedure TCustomRichEdit98.UpdateVerbs;
var
EnumOleVerb: IEnumOleVerb;
OleVerb: TOleVerb;
VerbInfo: TVerbInfo;
begin
DestroyVerbs;
FObjectVerbs := TStringList.Create;
if FSelObject.EnumVerbs(EnumOleVerb) = 0 then
begin
while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and
(OleVerb.lVerb >= 0) and
(OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do
begin
VerbInfo.Verb := OleVerb.lVerb;
VerbInfo.Flags := OleVerb.fuFlags;
FObjectVerbs.AddObject(OleVerb.lpszVerbName, TObject(VerbInfo));
end;
end;
end;
procedure TCustomRichEdit98.PopupVerbMenuClick(Sender: TObject);
begin
DoVerb((Sender as TMenuItem).Tag);
end;
procedure TCustomRichEdit98.DoVerb(Verb: Integer);
var
H: THandle;
R: TRect;
ClientSite: IOleClientSite;
PT:Integer;
AX,AY:Integer;
begin
if not Assigned(RichEditOle) or not Assigned(FSelObject) then Exit;
if Verb > 0 then begin
if FObjectVerbs = nil then UpdateVerbs;
if Verb >= FObjectVerbs.Count then
raise EOleError.Create('Invalid Verb');
Verb := Smallint(Integer(FObjectVerbs.Objects[Verb]) and $0000FFFF);
end else
if Verb = ovPrimary then Verb := 0;
H := Handle;
// PT:=Point(AX,AY);
SendMessage(H,EM_POSFROMCHAR,pt,0) ;
R:=BoundsRect;
// R := ClientRect;
OleCheck(RichEditOle.GetClientSite(ClientSite));
OleCheck(FSelObject.DoVerb(Verb, nil, ClientSite, 0, H, R));
end;
procedure TCustomRichEdit98.InsertObjectDialog;
var
Data: TOleUIInsertObject;
NameBuffer: array[0..255] of Char;
CreateInfo: TCreateInfo;
FNewInserted:Boolean;
begin
FNewInserted:=false;
FillChar(Data, SizeOf(Data), 0);
FillChar(NameBuffer, SizeOf(NameBuffer), 0);
Data.cbStruct := SizeOf(Data);
Data.dwFlags := IOF_SELECTCREATENEW;
Data.hWndOwner := Application.Handle;
Data.lpfnHook := OleDialogHook;
Data.lpszFile := NameBuffer;
Data.cchFile := SizeOf(NameBuffer);
try
if OleUIInsertObject(Data) = OLEUI_OK then begin
if Data.dwFlags and IOF_SELECTCREATENEW <> 0 then begin
CreateInfo.CreateType := ctNewObject;
CreateInfo.ClassID := Data.clsid;
end
else
begin
if Data.dwFlags and IOF_CHECKLINK = 0 then
CreateInfo.CreateType := ctFromFile
else
CreateInfo.CreateType := ctLinkToFile;
CreateInfo.FileName := NameBuffer;
end;
CreateInfo.ShowAsIcon := Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0;
CreateInfo.IconMetaPict := Data.hMetaPict;
CreateObjectFromInfo(CreateInfo);
if CreateInfo.CreateType = ctNewObject then
// begin
DoVerb(OvOpen);
// end
// else
// DoVerb(OVOpen);
end;
finally
DestroyMetaPict(Data.hMetaPict);
end;
end;
procedure TCustomRichEdit98.CreateObjectFromInfo(const CreateInfo:TCreateInfo);
var
Storage:IStorage;
OleObject:IOleObject;
OleSite:IOleClientSite;
ReObject:TReObject;
OleCache:IOLECache;
Data: TOleUIChangeIcon;
begin
try
RichEditOle.GetClientSite(OleSite);
RichEditOleCallback.GetNewStorage(Storage);
with CreateInfo do begin
case CreateType of
ctNewObject:
OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil,
OleSite, Storage, OleObject));
ctFromFile:
OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(FileName), IOleObject,
OLERENDER_DRAW, nil, OleSite, Storage, OleObject));
ctLinkToFile:
OleCheck(OleCreateLinkToFile(PWideChar(FileName), IOleObject,
OLERENDER_DRAW, nil, OleSite, Storage, OleObject));
ctFromData:
OleCheck(OleCreateFromData(DataObject, IOleObject,
OLERENDER_DRAW, nil, OleSite, Storage, OleObject));
ctLinkFromData:
OleCheck(OleCreateLinkFromData(DataObject, IOleObject,
OLERENDER_DRAW, nil, OleSite, Storage, OleObject));
end;
FillChar(ReObject, SizeOf(TReObject), 0);
ReObject.cbStruct:=SizeOf(TReObject);
ReObject.cp:=SelStart;
ReObject.oleobj:=OleObject;
ReObject.clsid:=Data.clsid;
ReObject.stg:=Storage;
ReObject.olesite:=OleSite;
ReObject.sizel.cx:=0;
ReObject.sizel.cy:=0;
ReObject.dwUser:=0;
FSelObject:= OleObject;
ReObject.dwFlags:={REO_BELOWBASELINE or} REO_DYNAMICSIZE or REO_RESIZABLE;
if CreateInfo.ShowAsIcon then
Begin
ReObject.dvaspect:=DVASPECT_ICON;
FDrawAspect:=DVASPECT_ICON;
SetDrawaspect(True,ICONMETAPICT);
end
else
begin
FDrawaspect:=DVASPECT_CONTENT;
ReObject.dvaspect:=DVASPECT_CONTENT;
end;
If CreateInfo.CreateType=ctNewObject then
ReObject.dwFlags:= ReObject.dwFlags or REO_BLANK;
RicheditOle.SetHostNames(PWideChar(WideString(Application.Title)),
PWideChar(WideString(Caption)));
Olecheck(RichEditOle.InsertObject(ReObject));
end;
except
raise;
end;
end;
procedure TCustomRichedit98.SetDrawAspect(Iconic: Boolean;
IconMetaPict: HGlobal);
var
OleCache: IOleCache;
EnumStatData: IEnumStatData;
OldAspect, AdviseFlags, Connection: Longint;
TempMetaPict: HGlobal;
FormatEtc: TFormatEtc;
Medium: TStgMedium;
ClassID: TCLSID;
StatData: TStatData;
ViewObject: IViewObject;
begin
OldAspect := FDrawAspect;
if Iconic then
begin
FDrawAspect := DVASPECT_ICON;
AdviseFlags := ADVF_NODATA;
end else
begin
FDrawAspect := DVASPECT_CONTENT;
AdviseFlags := ADVF_PRIMEFIRST;
end;
if (FDrawAspect <> OldAspect) or (FDrawAspect = DVASPECT_ICON) then
begin
OleCache := FSelObject as IOleCache;
if FDrawAspect <> OldAspect then
begin
OleCheck(OleCache.EnumCache(EnumStatData));
if EnumStatData <> nil then
while EnumStatData.Next(1, StatData, nil) = 0 do
if StatData.formatetc.dwAspect = OldAspect then
OleCache.Uncache(StatData.dwConnection);
FillChar(FormatEtc, SizeOf(FormatEtc), 0);
FormatEtc.dwAspect := FDrawAspect;
FormatEtc.lIndex := -1;
OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
end;
if FDrawAspect = DVASPECT_ICON then
begin
TempMetaPict := 0;
if IconMetaPict = 0 then
begin
OleCheck(FSelObject.GetUserClassID(ClassID));
TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
IconMetaPict := TempMetaPict;
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;
OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
OLECheck(OleCache.SetData(FormatEtc, Medium, False));
finally
DestroyMetaPict(TempMetaPict);
end;
end;
if FDrawAspect = DVASPECT_CONTENT then UpdateObject;
UpdateView;
end;
end;
function TCustomRichEdit98.PasteSpecialDialog: Boolean;
const
PasteFormatCount = 2;
var
Data: TOleUIPasteSpecial;
PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry;
CreateInfo: TCreateInfo;
begin
Result := False;
if not CanPaste then Exit;
FillChar(Data, SizeOf(Data), 0);
FillChar(PasteFormats, SizeOf(PasteFormats), 0);
Data.cbStruct := SizeOf(Data);
Data.hWndOwner := Application.Handle;
Data.lpfnHook := OleDialogHook;
Data.arrPasteEntries := @PasteFormats;
Data.cPasteEntries := PasteFormatCount;
Data.arrLinkTypes := @CFLinkSource;
Data.cLinkTypes := 1;
PasteFormats[0].fmtetc.cfFormat := CFEmbeddedObject;
PasteFormats[0].fmtetc.dwAspect := DVASPECT_CONTENT;
PasteFormats[0].fmtetc.lIndex := -1;
PasteFormats[0].fmtetc.tymed := TYMED_ISTORAGE;
PasteFormats[0].lpstrFormatName := '%s';
PasteFormats[0].lpstrResultText := '%s';
PasteFormats[0].dwFlags := OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON;
PasteFormats[1].fmtetc.cfFormat := CFLinkSource;
PasteFormats[1].fmtetc.dwAspect := DVASPECT_CONTENT;
PasteFormats[1].fmtetc.lIndex := -1;
PasteFormats[1].fmtetc.tymed := TYMED_ISTREAM;
PasteFormats[1].lpstrFormatName := '%s';
PasteFormats[1].lpstrResultText := '%s';
PasteFormats[1].dwFlags := OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON;
try
if OleUIPasteSpecial(Data) = OLEUI_OK then
begin
if Data.fLink then
CreateInfo.CreateType := ctLinkFromData else
CreateInfo.CreateType := ctFromData;
CreateInfo.ShowAsIcon := Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0;
CreateInfo.IconMetaPict := Data.hMetaPict;
CreateInfo.DataObject := Data.lpSrcDataObj;
CreateObjectFromInfo(CreateInfo);
Result := True;
end;
finally
DestroyMetaPict(Data.hMetaPict);
end;
end;
function TCustomRichedit98.GetCanPaste: Boolean;
var
DataObject: IDataObject;
begin
Result := (OleGetClipboard(DataObject) >= 0) and
((OleQueryCreateFromData(DataObject) = 0) or
(OleQueryLinkFromData(DataObject) = 0));
end;
procedure TCustomRichEdit98.UpdateObject;
begin
if FSelObject <> nil then
begin
OleCheck(FSelObject.Update);
Changed;
end;
end;
procedure TCustomRichEdit98.UpdateView;
var
ViewObject2: IViewObject2;
begin
if FSelObject.QueryInterface(IViewObject2, ViewObject2) >= 0 then
begin
ViewObject2.GetExtent(FDrawAspect, - 1, nil, FViewSize);
// AdjustBounds;
end;
Invalidate;
Changed;
end;
function TCustomRichedit98.ChangeIconDialog: Boolean;
var
Data: TOleUIChangeIcon;
begin
CheckObject;
Result := False;
FillChar(Data, SizeOf(Data), 0);
Data.cbStruct := SizeOf(Data);
Data.dwFlags := CIF_SELECTCURRENT;
Data.hWndOwner := Application.Handle;
Data.lpfnHook := OleDialogHook;
OleCheck(FSelObject.GetUserClassID(Data.clsid));
Data.hMetaPict := GetIconMetaPict;
try
if OleUIChangeIcon(Data) = OLEUI_OK then
begin
SetDrawAspect(True, Data.hMetaPict);
Result := True;
end;
finally
DestroyMetaPict(Data.hMetaPict);
end;
end;
function TCustomRichEdit98.GetIconMetaPict: HGlobal;
var
DataObject: IDataObject;
FormatEtc: TFormatEtc;
Medium: TStgMedium;
ClassID: TCLSID;
begin
CheckObject;
Result := 0;
if FDrawAspect = DVASPECT_ICON then
begin
FSelObject.QueryInterface(IDataObject, DataObject);
if DataObject <> nil then
begin
FormatEtc.cfFormat := CF_METAFILEPICT;
FormatEtc.ptd := nil;
FormatEtc.dwAspect := DVASPECT_ICON;
FormatEtc.lIndex := -1;
FormatEtc.tymed := TYMED_MFPICT;
if DataObject.GetData(FormatEtc, Medium) >= 0 then
Result := Medium.hMetaFilePict;
end;
end;
if Result = 0 then
begin
OleCheck(FSelObject.GetUserClassID(ClassID));
Result := OleGetIconOfClass(ClassID, nil, True);
end;
end;
procedure TCustomRichedit98.CheckObject;
begin
if FSelObject = nil then
raise EOleError.Create('EmptyDocument');
end;
procedure TCustomRichEdit98.CreateLinkToFile(const FileName: string;
Iconic: Boolean);
var
CreateInfo: TCreateInfo;
begin
CreateInfo.CreateType := ctLinkToFile;
CreateInfo.ShowAsIcon := Iconic;
CreateInfo.IconMetaPict := 0;
CreateInfo.FileName := FileName;
CreateObjectFromInfo(CreateInfo);
end;
procedure TCustomRichEdit98.CreateObject(const OleClassName: string;
Iconic: Boolean);
var
CreateInfo: TCreateInfo;
begin
CreateInfo.CreateType := ctNewObject;
CreateInfo.ShowAsIcon := Iconic;
CreateInfo.IconMetaPict := 0;
CreateInfo.ClassID := ProgIDToClassID(OleClassName);
CreateObjectFromInfo(CreateInfo);
end;
procedure TCustomRichEdit98.CreateObjectFromFile(const FileName: string;
Iconic: Boolean);
var
CreateInfo: TCreateInfo;
begin
CreateInfo.CreateType := ctFromFile;
CreateInfo.ShowAsIcon := Iconic;
CreateInfo.IconMetaPict := 0;
CreateInfo.FileName := FileName;
CreateObjectFromInfo(CreateInfo);
end;
procedure TCustomRichEdit98.StopGroupTyping;
begin
Perform(EM_STOPGROUPTYPING, 0, 0);
end;
function TCustomRichEdit98.GetSelType: TSelectionType;
var
B: Byte;
begin
B:= Perform(EM_SELECTIONTYPE, 0, 0);
Result:= TSelectionType(B);
end;
procedure TCustomRichEdit98.DoSetMaxLength(Value: Integer);
begin
if Value=0 then
Value:= MAXLONG;
SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);
end;
{ TDBRichEdit98 }
(*
constructor TDBRichEdit98.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
inherited ReadOnly := True;
FAutoDisplay := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
end;
destructor TDBRichEdit98.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TDBRichEdit98.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TDBRichEdit98.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TDBRichEdit98.BeginEditing;
begin
if not FDataLink.Editing then
try
if FDataLink.Field.IsBlob then
FDataSave := FDataLink.Field.AsString;
FDataLink.Edit;
finally
FDataSave := '';
end;
end;
procedure TDBRichEdit98.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
if FMemoLoaded then
begin
if (Key = VK_DELETE) or (Key = VK_BACK) or
((Key = VK_INSERT) and (ssShift in Shift)) or
(((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then
BeginEditing;
end;
end;
procedure TDBRichEdit98.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if FMemoLoaded then
begin
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
BeginEditing;
#27:
FDataLink.Reset;
end;
end else
begin
if Key = #13 then LoadMemo;
Key := #0;
end;
end;
procedure TDBRichEdit98.Change;
begin
if FMemoLoaded then FDataLink.Modified;
FMemoLoaded := True;
inherited Change;
end;
function TDBRichEdit98.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBRichEdit98.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TDBRichEdit98.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TDBRichEdit98.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TDBRichEdit98.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TDBRichEdit98.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TDBRichEdit98.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TDBRichEdit98.LoadMemo;
begin
if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
begin
try
Lines.Assign(FDataLink.Field);
FMemoLoaded := True;
except
{ Rich Edit Load failure }
on E:EOutOfResources do
Lines.Text := Format('(%s)', [E.Message]);
end;
EditingChange(Self);
end;
end;
procedure TDBRichEdit98.DataChange(Sender: TObject);
begin
if FDataLink.Field <> nil then
if FDataLink.Field.IsBlob then
begin
if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
begin
{ Check if the data has changed since we read it the first time }
if (FDataSave <> '') and (FDataSave = FDataLink.Field.AsString) then Exit;
FMemoLoaded := False;
LoadMemo;
end else
begin
Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
FMemoLoaded := False;
end;
end else
begin
if FFocused and FDataLink.CanModify then
Text := FDataLink.Field.Text
else
Text := FDataLink.Field.DisplayText;
FMemoLoaded := True;
end
else
begin
if csDesigning in ComponentState then Text := Name else Text := '';
FMemoLoaded := False;
end;
if HandleAllocated then
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
end;
procedure TDBRichEdit98.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
end;
procedure TDBRichEdit98.UpdateData(Sender: TObject);
begin
if FDataLink.Field.IsBlob then
FDataLink.Field.Assign(Lines) else
FDataLink.Field.AsString := Text;
end;
procedure TDBRichEdit98.SetFocused(Value: Boolean);
begin
if FFocused <> Value then
begin
FFocused := Value;
if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
FDataLink.Reset;
end;
end;
procedure TDBRichEdit98.CMEnter(var Message: TCMEnter);
begin
SetFocused(True);
inherited;
if SysLocale.FarEast and FDataLink.CanModify then
inherited ReadOnly := False;
end;
procedure TDBRichEdit98.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
SetFocused(False);
inherited;
end;
procedure TDBRichEdit98.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then LoadMemo;
end;
end;
procedure TDBRichEdit98.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
if not FMemoLoaded then LoadMemo else inherited;
end;
procedure TDBRichEdit98.WMCut(var Message: TMessage);
begin
BeginEditing;
inherited;
end;
procedure TDBRichEdit98.WMPaste(var Message: TMessage);
begin
BeginEditing;
inherited;
end;
procedure TDBRichEdit98.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
procedure TDBRichEdit98.DefineProperties(Filer: TFiler);
begin
end;
*)
(*
function TRTFProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TRTFProperty.Edit;
var
Editor: TRichEdit98Editor;
RE: TRichEdit98;
MS: TMemoryStream;
begin
Editor:= TRichEdit98Editor.Create(Application);
RE:= GetComponent(0) as TRichEdit98;
MS:= TMemoryStream.Create;
if RE.Perform(WM_GETTEXTLENGTH, 0, 0)>0 then
begin
RE.Lines.SaveToStream(MS);
MS.Position:= 0;
TRichEdit(Editor.Editor).Lines.LoadFromStream(MS);
Editor.Editor.Font:= RE.Font;
MS.Clear;
end
else
Editor.Editor.SelAttributes.Assign(RE.Font);
if Editor.ShowModal=mrOk then
if Editor.Editor.Perform(WM_GETTEXTLENGTH, 0, 0)>0 then
begin
Editor.Editor.Lines.SaveToStream(MS);
MS.Position:= 0;
RE.Clear;
TRichEdit(RE).Lines.LoadFromStream(MS);
Modified;
end
else
RE.Clear;
MS.Free;
Editor.Free;
end;
function TRTFProperty.GetValue: string;
begin
Result:= '(TStrings)';
end;
*)
constructor TRichEditOleCallback.Create(AOwner: TCustomRichEdit98);
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; var FrameInfo: TOleInPlaceFrameInfo): HRESULT;
begin
// Result:= E_NOTIMPL;
// exit;
Doc:=nil;
Frame := GetVCLFrameForm(ValidParentForm(FOwner));
Frame._AddRef;
with frameInfo do
begin
fMDIApp := False;
Frame.GetWindow(hWndFrame);
hAccel := 0;
cAccelEntries := 0;
end;
Result := S_OK;
end;
function TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HRESULT;
begin
// Result:=S_OK;
Result:= E_NOTIMPL;
end;
function TRichEditOleCallback.GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HRESULT;
begin
Result:= E_NOTIMPL;
end;
function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HRESULT;
begin
Result:= E_NOTIMPL;
end;
function TRichEditOleCallback.QueryInsertObject(const clsid: TCLSID; stg: IStorage;
cp: longint): HRESULT;
begin
Result:= S_OK;
end;
function TRichEditOleCallback.DeleteObject(oleobj: IOLEObject): HRESULT;
begin
FOwner.FSelObject:= nil;
oleobj.Close(OLECLOSE_NOSAVE);
Result:= S_OK;
end;
function TRichEditOleCallback.QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT;
begin
Result:= S_OK;
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 // allowable dest effects
// 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; oleobj: IOleObject;
const chrg: TCharRange; var menu: HMENU): HRESULT;
begin
menu:=0;
Result:= S_OK;
end;
var
OSVI: TOSVersionInfo;
initialization
OSVI.dwOSVersionInfoSize:= SizeOf(OSVI);
GetVersionEx(OSVI);
IsWinNT:= OSVI.dwPlatformId=VER_PLATFORM_WIN32_NT;
CF_RTF := RegisterClipboardFormat(RichEdit.CF_RTF);
CF_RTFNOOBJS := RegisterClipboardFormat(RichEdit.CF_RTFNOOBJS);
CF_RETEXTOBJ := RegisterClipboardFormat(RichEdit.CF_RETEXTOBJ);
end.
Reference in New Issue View Git Blame Copy Permalink