unit RichEdit2; { TRichEdit98 and DBRichEdit98 components for Delphi 3.0-4.0. version 1.40 Author Alexander Obukhov, Minsk, Belarus OLE support code written by Greg Chapman Mike Lindre Tomasz Kustra Sigi Thanks to: Oliver Matla Glenn Benes Sven Opitz Jolios Lin Tom Wang Doron Tal Alexander Halser Arentjan Banck Andre Van Der Merwe Iain Magee Sigi Rob Schoenaker Laszlo Kovacs } 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 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 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 (N1); 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.cpMinCR.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 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.