{ Copyright (C) 2001, Windoze, [email protected] This program is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Library Public License for more details. You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. }{ RICHOLE.PAS
Purpose: OLE Extensions to the Rich Text Editor }
{ Translated CPP header file, this file was NOT well-formed for C++ Builder. Don't use it under such environment unless you modified it properly. }unit RichOle;interfaceuses Windows, Messages, SysUtils, Classes, RichEdit, ActiveX;const // IID IID_IRichEditOle : TGUID = '{00020D00-0000-0000-C000-000000000046}'; IID_IRichEditOleCallback : TGUID = '{00020D03-0000-0000-C000-000000000046}';// Flags to specify which interfaces should be returned in the structure above REO_GETOBJ_NO_INTERFACES = $00000000; REO_GETOBJ_POLEOBJ = $00000001; REO_GETOBJ_PSTG = $00000002; REO_GETOBJ_POLESITE = $00000004; REO_GETOBJ_ALL_INTERFACES = $00000007;// Place object at selection REO_CP_SELECTION = -1;// Use character position to specify object instead of index REO_IOB_SELECTION = -1; REO_IOB_USE_CP = -2;// Object flags REO_NULL = $00000000; // No flags REO_READWRITEMASK = $0000003F; // Mask out RO bits REO_DONTNEEDPALETTE = $00000020; // Object doesn't need palette REO_BLANK = $00000010; // Object is blank REO_DYNAMICSIZE = $00000008; // Object defines size always REO_INVERTEDSELECT = $00000004; // Object drawn all inverted if sel REO_BELOWBASELINE = $00000002; // Object sits below the baseline REO_RESIZABLE = $00000001; // Object may be resized REO_LINK = $80000000; // Object is a link (RO) REO_STATIC = $40000000; // Object is static (RO) REO_SELECTED = $08000000; // Object selected (RO) REO_OPEN = $04000000; // Object open in its server (RO) REO_INPLACEACTIVE = $02000000; // Object in place active (RO) REO_HILITED = $01000000; // Object is to be hilited (RO) REO_LINKAVAILABLE = $00800000; // Link believed available (RO) REO_GETMETAFILE = $00400000; // Object requires metafile (RO)// flags for IRichEditOle::GetClipboardData(), // IRichEditOleCallback::GetClipboardData() and // IRichEditOleCallback::QueryAcceptData() RECO_PASTE = $00000000; // paste from clipboard RECO_DROP = $00000001; // drop RECO_COPY = $00000002; // copy to the clipboard RECO_CUT = $00000003; // cut to the clipboard RECO_DRAG = $00000004; // dragtype LONG=Integer;// Structure passed to GetObject and InsertObject _reobject = packed record cbStruct : DWORD; cp : LONG; clsid : TGUID; poleobject : IOleObject; pstg : IStorage; polesite : IOleClientSite; sizel : SIZE; dvaspect : DWORD; dwFlags : DWORD; dwUser : DWORD; end; REOBJECT=_reobject; PREOBJECT=^REOBJECT; LPREOBJECT=PREOBJECT; IRichEditOle = interface(IUnknown) ['{00020D00-0000-0000-C000-000000000046}'] function GetClientSite(out lplpolesite : IOleClientSite) : HRESULT; stdcall; function GetObjectCount : LONG; stdcall; function GetLinkCount : LONG; stdcall; function GetObject(iob : LONG; var lpreobject : REOBJECT; dwFlags : DWORD) : HRESULT; stdcall; function InsertObject(var lpreobject : REOBJECT) : HRESULT; stdcall; function ConvertObject(iob : LONG; rclsidNew : TGUID; lpsreUserTypeNew : LPCSTR) : HRESULT; stdcall; function ActivateAs(rclsid : TGUID; rclsidAs : TGUID) : HRESULT; stdcall; function SetHostNames(lpstrContainerApp : LPCSTR; lpstrContainerObj : LPCSTR) : HRESULT; stdcall; function SetLinkAvailable(iob : LONG; fAvailable : BOOL) : HRESULT; stdcall; function SetDvaspect(iob : LONG; dvaspect : DWORD) : HRESULT; stdcall; function HandsOffStorage(iob : LONG) : HRESULT; stdcall; function SaveCompleted(iob : LONG; lpstg : IStorage) : HRESULT; stdcall; function InPlaveDeactivate : HRESULT; stdcall; function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall; function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD; out lplpdataobj : IDataObject) : HRESULT; stdcall; function ImportDataObject(out lpdataobj : IDataObject; cf : TClipFormat; hMetaPict : HGLOBAL) : HRESULT; stdcall; end; IRichEditOleCallback = interface(IUnknown) ['{00020D03-0000-0000-C000-000000000046}'] function GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall; function GetInPlaceContext(out lplpFrame : IOleInplaceFrame; out lplpDoc : IOleInplaceUIWindow; var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall; function ShowContainerUI(fShow : BOOL) : HRESULT; stdcall; function QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall; function DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall; function QueryAcceptData(lpoleobj : IOleObject; var lpcfFormat : TClipFormat; reco : DWORD; fReally : BOOL; hMetaPict : HGLOBAL) : HRESULT; stdcall; function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall; function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD; out lplpdataobj : IDataObject) : HRESULT; stdcall; function GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall; function GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall; end; PRICHEDITOLECALLBACK = ^IRichEditOleCallback; LPRICHEDITOLECALLBACK = PRICHEDITOLECALLBACK;implementationend.
{ Copyright (C) 2001, Windoze, [email protected] This program is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Library Public License for more details. You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. }{ RICHEDITOR2EDITOR.PAS
Purpose: Component editor for TRichEdit2 }
unit RichEdit2Editor;interface{ If you have Win2KDlg components, you can enable this option. Ok, forget it :) } {.$DEFINE USES_WIN2KDLG}uses Windows, Sysutils, Messages, ComObj, Classes, Controls, ActiveX, ComCtrls, RichEdit2, RichOle, dsgnintf, shellapi, Dialogs {$IFDEF USES_WIN2KDLG} ,Win2KDlg {$ENDIF} ;type TRichEdit2Editor = class(TComponentEditor) function GetVerbCount : Integer; override; function GetVerb(Index : Integer) : string; override; procedure ExecuteVerb(Index : Integer); override; procedure Edit; override; procedure EditRichEditContent(re : TRichEdit2); procedure LoadRichTextFile(re : TRichEdit2); procedure Clear(re : TRichEdit2); end; procedure Register;implementationfunction TRichEdit2Editor.GetVerbCount : Integer; begin Result := (inherited GetVerbCount) + 3; end;function TRichEdit2Editor.GetVerb(Index : Integer) : string; begin if Index < (inherited GetVerbCount) then Result := inherited GetVerb(Index) else if Index = inherited GetVerbCount then Result := 'Edit...' else if Index = (inherited GetVerbCount)+1 then Result := 'Load File' else if Index = (inherited GetVerbCount)+2 then Result := 'Clear'; end;procedure TRichEdit2Editor.ExecuteVerb(Index : Integer); begin if Index < inherited GetVerbCount then inherited else if Index = inherited GetVerbCount then EditRichEditContent(Component as TRichEdit2) else if Index = (inherited GetVerbCount)+1 then LoadRichTextFile(Component as TRichEdit2) else if Index = (inherited GetVerbCount)+2 then Clear(Component as TRichEdit2) end;procedure TRichEdit2Editor.Edit; begin EditRichEditContent(Component as TRichEdit2); end;{ This is a quick-and-dirty content editor, simply save to a temporary file and run associated program to edit saved file, then reload the file into control. } procedure TRichEdit2Editor.EditRichEditContent(re : TRichEdit2); function MakeTempFileName : string; var pszTempDir : PChar; pszFileName : PChar; begin pszTempDir := AllocMem(MAX_PATH); pszFileName := AllocMem(MAX_PATH); GetTempPath(MAX_PATH, pszTempDIr); // I've to create a new file to get a temporary file name :( GetTempFileName(pszTempDir, 'tnt', 0, pszFileName); Result := pszFileName; // Delete created file, we need only a file name DeleteFile(Result); FreeMem(pszTempDir); FreeMem(pszFileName); end; var fn : string; fs : TFileStream; se : SHELLEXECUTEINFO; begin if re.PlainText then fn := MakeTempFileName + '.txt' else fn := MakeTempFileName + '.rtf'; fs := TFileStream.Create(fn, fmCreate); re.SaveToStream(fs, re.PlainText); fs.Free; se.cbSize := SizeOf(se); se.fMask := SEE_MASK_NOCLOSEPROCESS; se.Wnd := re.Handle; se.lpVerb := nil; se.lpFile := PChar(fn); se.lpParameters := nil; se.lpDirectory := '.'; se.nShow := SW_SHOW; ShellExecuteEx(@se); // Wait until program closed WaitForSingleObject(se.hProcess, INFINITE); fs := TFileStream.Create(fn, fmOpenRead); re.LoadFromStream(fs, re.PlainText); fs.Free; DeleteFile(fn); // Since the 'Data' property is NOT a real property, we've to // call IFormDesigner.Modified manually GetDesigner.Modified; end;procedure TRichEdit2Editor.LoadRichTextFile(re : TRichEdit2); var {$IFDEF USES_WIN2KDLG} dlg : TOpenDialogEx; {$ELSE} dlg : TOpenDialog; {$ENDIF} fs : TFileStream; begin {$IFDEF USES_WIN2KDLG} dlg := TOpenDialogEx.Create(re.Owner); dlg.ShowPlacesBar := True; {$ELSE} dlg := TOpenDialog.Create(re.Owner); {$ENDIF} if re.PlainText then dlg.Filter := 'Text Files(*.txt)|*.TXT|All Files(*.*)|*.*|' else dlg.Filter := 'RTF Files(*.rtf)|*.RTF|All Files(*.*)|*.*|'; dlg.FilterIndex := 1; dlg.Options := [ofHideReadOnly,ofShowHelp,ofPathMustExist,ofFileMustExist,ofEnableSizing]; if dlg.Execute then begin fs := TFileStream.Create(dlg.FileName, fmOpenRead); re.LoadFromStream(fs, re.PlainText); fs.Free; GetDesigner.Modified; end; dlg.Free; end;procedure TRichEdit2Editor.Clear(re : TRichEdit2); begin re.Clear; end;procedure Register; begin RegisterComponentEditor(TCustomRichEdit2, TRichEdit2Editor); end;end.
unit RichEdit2;interface{ Remove prior dot to enable OLE Inplace activation Unfortunately, current implementation of inplace-activation still buggy, sometimes inserted object cannot update properly, so you'd better don't enable this feature... } {.$DEFINE USES_IPACTIVATE}{ Remove prior dot to add a TextDocument property, with this you can access an ITOMDocument interface owned by the richedit control. You must generate tom_TLB.pas/dcr from you riched20.dll, I don't supply this file to avoid version conflict. } {.$DEFINE USES_TOM}uses Windows, Messages, ComObj, Classes, Controls, ActiveX, ComCtrls, ComStrs, RichEdit, RichOle, Graphics, SysUtils, forms {$IFDEF USES_IPACTIVATE} , olectnrs {$ENDIF}{$IFDEF USES_TOM} , tom_TLB {$ENDIF} ;const EM_GETZOOM = (WM_USER + 224); EM_SETZOOM = (WM_USER + 225);type TRichEditLinkNotify = procedure(Sender: TObject; StartPos, EndPos: Integer; NotifyMessage : Longint; var Handled: Boolean) of object; TRichEditMargin = class(TPersistent) protected FRECtrl : TCustomRichEdit; FWidth : Integer; FUseFontInfo : Boolean; FDirect : Boolean; // True = Left, False = Right FPlainTextMode : Boolean; procedure SetWidth(AWidth : Integer); procedure SetUseFontInfo(AUseFontInfo : Boolean); procedure SetMargin; property UseFontInfo : Boolean read FUseFontInfo write SetUseFontInfo; public constructor Create(AOwner : TComponent); virtual; procedure Assign(Source: TPersistent); override; published property Width : Integer read FWidth write SetWidth; end; TCustomRichEdit2 = class(TCustomRichEdit, IRichEditOleCallback) private REObject : IRichEditOle; FLeftMargin, FRightMargin : TRichEditMargin; FLinkNotify : TRichEditLinkNotify; FPlainTextMode : Boolean; FLines : TStrings; ReloadStream : TMemoryStream; {$IFDEF USES_TOM} TOMDocument : ITextDocument; {$ENDIF} protected // Interface methods // *** IRichEditOleCallback methods *** function GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall; function GetInPlaceContext(out lplpFrame : IOleInplaceFrame; out lplpDoc : IOleInplaceUIWindow; var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall; function ShowContainerUI(fShow : BOOL) : HRESULT; stdcall; function QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall; function DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall; function QueryAcceptData(lpoleobj : IOleObject; var lpcfFormat : TClipFormat; reco : DWORD; fReally : BOOL; hMetaPict : HGLOBAL) : HRESULT; stdcall; function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall; function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD; out lplpdataobj : IDataObject) : HRESULT; stdcall; function GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall; function GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall; // Message functions procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; function SaveClipboard(NumObj, NumChars: Integer): Boolean; function ProtectChange(StartPos, EndPos: Integer): Boolean; function LinkNotify(StartPos, EndPos: Integer; NotifyMessage : Longint): Boolean; // Virtual functions procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; function ReadFromStream(Stream : TStream; var Buffer; var Count : Longint) : Longint; virtual; function WriteToStream(Stream : TStream; const Buffer; var Count : Longint) : Longint; virtual; procedure DefineProperties(Filer: TFiler); override; procedure ReadData(Stream : TStream); procedure WriteData(Stream : TStream); // Properties; function GetAutoURLDetect : Boolean; procedure SetAutoURLDetect(FActive : Boolean); function GetCanRedo : Boolean; procedure SetSelectionVisible(FVisible : Boolean); function GetZoomRatio : Real; procedure SetZoomRatio(AZoomRatio : Real); procedure SetPlainTextMode(ATextMode : Boolean); procedure SetLines(Value: TStrings);{$IFDEF USES_TOM} function GetTOMDocument : ITextDocument; function UndoEx(Count : Longint) : Longint; function RedoEx(Count : Longint) : Longint; {$ENDIF} public constructor Create(AOwner : TComponent); override; procedure DestroyWnd; override; destructor Destroy; override; // Methods procedure Clear; override; procedure LoadFromStream(Stream : TStream; FromText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False); procedure SaveToStream(Stream : TStream; ToText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False); procedure Redo; function CanPaste(ClipboardFormat : WORD=0) : Boolean; // Properties property CanRedo : Boolean read GetCanRedo; property SelectionVisible : Boolean write SetSelectionVisible; property AutoURLDetect : Boolean read GetAutoURLDetect write SetAutoURLDetect; property LeftMargin : TRichEditMargin read FLeftMargin write FLeftMargin; property RightMargin : TRichEditMargin read FRightMargin write FRightMargin; property ZoomRatio : Real read GetZoomRatio write SetZoomRatio; {$IFDEF USES_TOM} property TextDocument : ITextDocument read GetTOMDocument; {$ENDIF} // Changed, not fully implemented, yet property PlainText : Boolean read FPlainTextMode write SetPlainTextMode; // Events property OnLinkNotify : TRichEditLinkNotify read FLinkNotify write FLinkNotify; property Lines read FLines write SetLines; published end; TRichEdit2 = class(TCustomRichEdit2) published property Align; property Alignment; property Anchors; property AutoURLDetect; property BiDiMode; property BorderStyle; property BorderWidth; property Color; property Ctl3D; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property HideSelection; property HideScrollBars; property ImeMode; property ImeName; property Constraints; property Lines; property MaxLength; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PlainText; property PopupMenu; property ReadOnly; property ScrollBars; property ShowHint; property TabOrder; property TabStop default True; property Visible; property WantTabs; property WantReturns; property WordWrap; property LeftMargin; property RightMargin; property ZoomRatio; property OnChange; property OnContextPopup; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnProtectChange; property OnResizeRequest; property OnSaveClipboard; property OnSelectionChange; property OnStartDock; property OnStartDrag; property OnLinkNotify; end;{ Need a TDBRichEdit2? Do it youself. :) Maybe you've to use a BLOB field to store data... }
Is That really OK?! TKS
procedure Register;implementationtype // Copy from VCL source and remove some members TRichEdit2Strings = class(TStrings) private RichEdit: TCustomRichEdit2; procedure EnableChange(const Value: Boolean); protected function Get(Index: Integer): string; override; function GetCount: Integer; override; procedure Put(Index: Integer; const S: string); override; procedure SetUpdateState(Updating: Boolean); override; procedure SetTextStr(const Value: string); override; public procedure Clear; override; procedure AddStrings(Strings: TStrings); override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: string); override; end;procedure TRichEdit2Strings.AddStrings(Strings: TStrings); var SelChange: TNotifyEvent; begin SelChange := RichEdit.OnSelectionChange; RichEdit.OnSelectionChange := nil; try inherited AddStrings(Strings); finally RichEdit.OnSelectionChange := SelChange; end; end;function TRichEdit2Strings.GetCount: Integer; begin Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0); if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle, EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result); end;function TRichEdit2Strings.Get(Index: Integer): string; var Text: array[0..4095] of Char; L: Integer; begin Word((@Text)^) := SizeOf(Text); L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text)); if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2); SetString(Result, Text, L); end;procedure TRichEdit2Strings.Put(Index: Integer; const S: string); var Selection: TCharRange; begin if Index >= 0 then begin Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0); if Selection.cpMin <> -1 then begin Selection.cpMax := Selection.cpMin + SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0); SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S))); end; end; end;procedure TRichEdit2Strings.Insert(Index: Integer; const S: string); var L: Integer; Selection: TCharRange; Fmt: PChar; Str: string; begin if Index >= 0 then begin Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0); if Selection.cpMin >= 0 then Fmt := '%s'#13#10 else begin Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0); if Selection.cpMin < 0 then Exit; L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0); if L = 0 then Exit; Inc(Selection.cpMin, L); Fmt := #13#10'%s'; end; Selection.cpMax := Selection.cpMin; SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); Str := Format(Fmt, [S]); SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));{ Removed if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then raise EOutOfResources.Create(sRichEditInsertError); } end; end;procedure TRichEdit2Strings.Delete(Index: Integer); const Empty: PChar = ''; var Selection: TCharRange; begin if Index < 0 then Exit; Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0); if Selection.cpMin <> -1 then begin Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0); if Selection.cpMax = -1 then Selection.cpMax := Selection.cpMin + SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0); SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty)); end; end;procedure TRichEdit2Strings.Clear; begin RichEdit.Clear; end;procedure TRichEdit2Strings.SetUpdateState(Updating: Boolean); begin if RichEdit.Showing then SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0); if not Updating then begin RichEdit.Refresh; RichEdit.Perform(CM_TEXTCHANGED, 0, 0); end; end;procedure TRichEdit2Strings.EnableChange(const Value: Boolean); var EventMask: Longint; begin with RichEdit do begin if Value then EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE else EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE; SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask); end; end;procedure TRichEdit2Strings.SetTextStr(const Value: string); begin EnableChange(False); try inherited SetTextStr(Value); finally EnableChange(True); end; end;{ procedure TRichEdit2Strings.LoadFromStream(Stream: TStream); begin raise Exception.Create('Not implemented function'); end;procedure TRichEdit2Strings.SaveToStream(Stream: TStream); begin raise Exception.Create('Not implemented function'); end;procedure TRichEdit2Strings.LoadFromFile(const FileName: string); begin raise Exception.Create('Not implemented function'); end;procedure TRichEdit2Strings.SaveToFile(const FileName: string); begin raise Exception.Create('Not implemented function'); end; }constructor TRichEditMargin.Create(AOwner : TComponent); begin FWidth := 4; FUseFontInfo := False; end;procedure TRichEditMargin.Assign(Source : TPersistent); begin FWidth := (Source as TRichEditMargin).FWidth; FUseFontInfo := (Source as TRichEditMargin).FUseFontInfo; end;procedure TRichEditMargin.SetMargin; var wParam : DWORD; lParam : DWORD; begin if FDirect then begin // Left margin wParam := EC_LEFTMARGIN; lParam := FWidth; if FUseFontInfo then begin wParam := wParam or EC_USEFONTINFO; lParam := EC_USEFONTINFO; end; end else begin // Right margin wParam := EC_RIGHTMARGIN; lParam := FWidth shl 16; if FUseFontInfo then begin wParam := wParam or EC_USEFONTINFO; lParam := $FFFF0000; end; end; SendMessage(FRECtrl.Handle, EM_SETMARGINS, wParam, lParam); end;procedure TRichEditMargin.SetWidth(AWidth : Integer); begin FWidth := AWidth; SetMargin; end;procedure TRichEditMargin.SetUseFontInfo(AUseFontInfo : Boolean); begin FUseFontInfo := AUseFontInfo; SetMargin; end;constructor TCustomRichEdit2.Create(AOwner : TComponent); begin inherited; FPlainTextMode := False; LeftMargin := TRichEditMargin.Create(Self); LeftMargin.FRECtrl := Self; LeftMargin.FDirect := True; RightMargin := TRichEditMargin.Create(Self); RightMargin.FRECtrl := Self; RightMargin.FDirect := False; FLines := TRichEdit2Strings.Create; TRichEdit2Strings(FLines).RichEdit := Self; end;
destructor TCustomRichEdit2.Destroy; begin LeftMargin.Free; RightMargin.Free; inherited; end;procedure TCustomRichEdit2.CreateParams(var Params: TCreateParams); begin inherited; CreateSubClass(Params, 'RICHEDIT20A'); with Params do begin WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); end; end;procedure TCustomRichEdit2.CreateWnd; var pI : IRichEditOleCallback; begin inherited; SendMessage(Handle, WM_SETFONT, Font.Handle, 0); pI := Self; SendMessage(Handle, EM_SETOLECALLBACK, 0, Integer(Pointer(pI))); SendMessage(Handle, EM_SETEVENTMASK, 0, ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED or ENM_LINK); LeftMargin.SetMargin; RightMargin.SetMargin; // Some properties' changing will re-create the window, to keep the content // we have to save and reload. // Reload data if needed if ReloadStream <> nil then begin ReloadStream.Position := 0; LoadFromStream(ReloadStream); ReloadStream.Free; ReloadStream := nil; end;end;procedure TCustomRichEdit2.DestroyWnd; begin // Release interfaces if REObject<>nil then begin REObject := nil; end; {$IFDEF USES_TOM} if TOMDocument<>nil then begin TOMDocument := nil; end; {$ENDIF} // Tempororally save data if needed if not (csDestroying in ComponentState) then begin ReloadStream := TMemoryStream.Create; SaveToStream(ReloadStream); end; inherited; end;type PENLink = ^TENLink;procedure TCustomRichEdit2.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); Filer.DefineBinaryProperty('Data', ReadData, WriteData, True); end;procedure TCustomRichEdit2.ReadData(Stream : TStream); var Size : Longint; TempStream : TMemoryStream; begin TempStream := TMemoryStream.Create; try Stream.ReadBuffer(Size, SizeOf(Size)); if Size>0 then begin TempStream.CopyFrom(Stream, Size); TempStream.position:= 0; LoadFromStream(TempStream); end; finally TempStream.Free; end; end;procedure TCustomRichEdit2.WriteData(Stream : TStream); var Size : Longint; TempStream : TMemoryStream; begin TempStream := TMemoryStream.Create; try SaveToStream(TempStream); TempStream.position:= 0; Size:= TempStream.Size; Stream.WriteBuffer(Size, SizeOf(Size)); if Size>0 then Stream.WriteBuffer(PChar(TempStream.Memory)^, Size); finally TempStream.free; end; end;// Copy from VCL, mostly procedure TCustomRichEdit2.CNNotify(var Message: TWMNotify); begin with Message do case NMHdr^.code of EN_SELCHANGE: SelectionChange; EN_REQUESTRESIZE: RequestSize(PReqSize(NMHdr)^.rc); EN_SAVECLIPBOARD: with PENSaveClipboard(NMHdr)^ do if not SaveClipboard(cObjectCount, cch) then Result := 1; EN_PROTECTED: with PENProtected(NMHdr)^.chrg do if not ProtectChange(cpMin, cpMax) then Result := 1; EN_LINK: with PENLink(NMHdr)^.chrg do if LinkNotify(cpMin, cpMax, PENLink(NMHdr)^.msg) then Message.Result := 1; end; end;// Copy from VCL function TCustomRichEdit2.SaveClipboard(NumObj, NumChars: Integer): Boolean; begin Result := True; if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result); end;// Copy from VCL function TCustomRichEdit2.ProtectChange(StartPos, EndPos: Integer): Boolean; begin Result := False; if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result); end;function TCustomRichEdit2.LinkNotify(StartPos, EndPos: Integer; NotifyMessage : Longint): Boolean; begin Result := False; if Assigned(OnLinkNotify) then OnLinkNotify(Self, StartPos, EndPos, NotifyMessage, Result); end;function TCustomRichEdit2.GetAutoURLDetect; begin Result := Perform(EM_GETAUTOURLDETECT, 0, 0)=1; end;procedure TCustomRichEdit2.SetAutoURLDetect(FActive : Boolean); begin SendMessage(Handle, EM_AUTOURLDETECT, Integer(FActive), 0); end;function TCustomRichEdit2.GetZoomRatio : Real; var numerator, denominator : WORD; begin SendMessage(Handle, EM_GETZOOM, Longint(@numerator), Longint(@denominator)); if (denominator=0) or (numerator=0) then Result := 1 else Result := numerator/denominator; end;procedure TCustomRichEdit2.SetZoomRatio(AZoomRatio : Real); var numerator, denominator : DWORD; begin denominator := 100; numerator := Round(AZoomRatio * 100); SendMessage(Handle, EM_SETZOOM, numerator, denominator); end;procedure TCustomRichEdit2.SetPlainTextMode(ATextMode : Boolean); var cf2 : CHARFORMAT2; begin cf2.cbSize := SizeOf(cf2); cf2.dwMask := CFM_BACKCOLOR or CFM_CHARSET or CFM_COLOR or CFM_FACE or CFM_SIZE or CFM_UNDERLINETYPE or CFM_WEIGHT; cf2.dwEffects := 0; cf2.yHeight := -(Font.Height) * 1440 div Font.PixelsPerInch; cf2.yOffset := 0; cf2.crTextColor := Font.Color; cf2.bCharSet := Font.Charset; case Font.Pitch of fpDefault: cf2.bPitchAndFamily := DEFAULT_PITCH; fpFixed: cf2.bPitchAndFamily := FIXED_PITCH; fpVariable: cf2.bPitchAndFamily := VARIABLE_PITCH; end; StrLCopy(cf2.szFaceName, PChar(Font.Name), 31); if fsBold in Font.Style then cf2.wWeight := FW_BOLD else cf2.wWeight := FW_NORMAL; if fsUnderLine in Font.Style then cf2.bUnderlineType := CFU_UNDERLINE else cf2.bUnderlineType := CFU_UNDERLINENONE; cf2.crBackColor := ColorToRGB(Color); SendMessage(Handle, EM_SETCHARFORMAT, SCF_ALL, Integer(@cf2)); FPlainTextMode := ATextMode; end;{$IFDEF USES_TOM} procedure TCustomRichEdit2.Clear; begin TextDocument.New; end; {$ELSE} type SETTEXTEX=packed record flags : DWORD; codepage : UINT; end; const ST_DEFAULT = 0; ST_KEEPUNDO = 1; ST_SELECTION = 2; EM_SETTEXTEX = (WM_USER + 97); procedure TCustomRichEdit2.Clear; var st : SETTEXTEX; ch : Char; begin st.flags := ST_DEFAULT; st.codepage := CP_ACP; ch := #0; SendMessage(Handle, EM_SETTEXTEX, Integer(@st), Integer(@ch)); end; {$ENDIF}function TCustomRichEdit2.GetCanRedo : Boolean; begin Result := Perform(EM_CANREDO, 0, 0)<>0; end;procedure TCustomRichEdit2.Redo; begin SendMessage(Handle, EM_REDO, 0, 0); end;{$IFDEF USES_TOM} function TCustomRichEdit2.UndoEx(Count : Longint) : Longint; begin Result := TextDocument.Undo(Count); end;function TCustomRichEdit2.RedoEx(Count : Longint) : Longint; begin Result := TextDocument.Redo(Count); end; {$ENDIF}
function TCustomRichEdit2.CanPaste(ClipboardFormat : WORD=0) : Boolean; begin Result := SendMessage(Handle, EM_CANPASTE, ClipboardFormat, 0) <> 0; end;procedure TCustomRichEdit2.SetSelectionVisible(FVisible : Boolean); begin SendMessage(Handle, EM_HIDESELECTION, Longint(not FVisible), 0); end;{$IFDEF USES_TOM} function TCustomRichEdit2.GetTOMDocument : ITextDocument; begin if TOMDocument=nil then begin SendMessage(Handle, EM_GETOLEINTERFACE, 0, Longint(@REObject)); TOMDocument := REObject as ITextDocument; end; Result := TOMDocument; end; {$ENDIF}procedure TCustomRichEdit2.SetLines(Value: TStrings); begin FLines.Assign(Value); end;// EM_STREAMIN/OUT implementations type TRichEditExCallback = record RichEditEx : TCustomRichEdit2; Stream : TStream; FRead : Boolean; end; PRichEditExCallback = ^TRichEditExCallback;function RichEditExStreamCallback(dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall; var pCallBack : PRichEditExCallback; begin pCallBack := PRichEditExCallback(dwCookie); pcb := cb; if pCallBack^.FRead then Result := pCallBack^.RichEditEx.ReadFromStream(pCallBack^.Stream, pbBuff^, pcb) else Result := pCallBack^.RichEditEx.WriteToStream(pCallBack^.Stream, pbBuff^, pcb); end;procedure TCustomRichEdit2.LoadFromStream(Stream : TStream; FromText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False); var es : TEditStream; cb : TRichEditExCallback; Options : Longint; begin cb.Stream := Stream; cb.RichEditEx := Self; cb.FRead := True; es.dwCookie := Longint(@cb); es.dwError := 0; es.pfnCallback := RichEditExStreamCallback; // prepare options Options := 0; if FromText then Options := Options or SF_TEXT else Options := Options or SF_RTF; if Selection then Options := Options or SFF_SELECTION; if Unicode then Options := Options or SF_UNICODE; SendMessage(Handle, EM_STREAMIN, Options, Longint(@es)); // Check result if es.dwError<>0 then raise EReadError.CreateFmt('%s.LoadFromStream error, Error code is %d', [Name, es.dwError]); end;procedure TCustomRichEdit2.SaveToStream(Stream : TStream; ToText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False); var es : TEditStream; cb : TRichEditExCallback; Options : Longint; begin cb.Stream := Stream; cb.RichEditEx := Self; cb.FRead := False; es.dwCookie := Longint(@cb); es.dwError := 0; es.pfnCallback := RichEditExStreamCallback; // prepare options Options := 0; if ToText then Options := Options or SF_TEXT else Options := Options or SF_RTF; if Selection then Options := Options or SFF_SELECTION; if Unicode then Options := Options or SF_UNICODE; SendMessage(Handle, EM_STREAMOUT, Options, Longint(@es)); // Check result if es.dwError<>0 then raise EReadError.CreateFmt('%s.SaveToStream error, Error code is %d', [Name, es.dwError]); end;function TCustomRichEdit2.ReadFromStream(Stream : TStream; var Buffer; var Count : Longint) : Longint; begin Count := Stream.Read(Buffer, Count); Result := 0; end;function TCustomRichEdit2.WriteToStream(Stream : TStream; const Buffer; var Count : Longint) : Longint; begin Count := Stream.Write(Buffer, Count); Result := 0; end;// *** IRichEditOleCallback methods *** function TCustomRichEdit2.GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall; var LockBytes: ILockBytes; begin Result := E_NOTIMPL; if FPlainTextMode then Exit; Result:= S_OK; try OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes)); OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, lplpstg)); except Result:= E_OUTOFMEMORY; end; end; {$IFDEF USES_IPACTIVATE} // Copy from VCL function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm; begin if Form.OleFormObject = nil then TOleForm.Create(Form); Result := Form.OleFormObject as IVCLFrameForm; end;// Copy from VCL function IsFormMDIChild(Form: TCustomForm): Boolean; begin Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild); end; {$ENDIF}function TCustomRichEdit2.GetInPlaceContext(out lplpFrame : IOleInplaceFrame; out lplpDoc : IOleInplaceUIWindow; var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall; begin {$IFDEF USES_IPACTIVATE} lplpDoc := GetVCLFrameForm(ValidParentForm(Owner as TControl)); lplpFrame := lplpDoc as IOleInplaceFrame; if IsFormMDIChild(GetVCLFrameForm(ValidParentForm(Owner as TControl)).Form) then begin lplpFrame := GetVCLFrameForm(Application.MainForm); end; with lpFrameInfo do begin cb := sizeof(lpFrameInfo); fMDIApp := False; lplpFrame.GetWindow(hWndFrame); hAccel := 0; cAccelEntries := 0; end; lpFrameInfo := lpFrameInfo; Result:= S_OK; {$ELSE} Result := E_NOTIMPL; {$ENDIF} end;function TCustomRichEdit2.ShowContainerUI(fShow : BOOL) : HRESULT; stdcall; begin {$IFDEF USES_IPACTIVATE} if fShow then with GetVCLFrameForm(ValidParentForm(Owner as TControl)) do begin SetMenu(0, 0, 0); ClearBorderSpace; end; {$ENDIF} Result := S_OK; end;function TCustomRichEdit2.QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall; begin Result := S_OK; if FPlainTextMode then begin Result := S_FALSE; Exit; end; end;function TCustomRichEdit2.DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall; begin Result := S_OK; end;function TCustomRichEdit2.QueryAcceptData(lpoleobj : IOleObject; var lpcfFormat : TClipFormat; reco : DWORD; fReally : BOOL; hMetaPict : HGLOBAL) : HRESULT; stdcall; begin if FPlainTextMode then lpcfFormat := CF_TEXT; Result := S_OK; end;function TCustomRichEdit2.ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall; begin Result := E_NOTIMPL; end;function TCustomRichEdit2.GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD; out lplpdataobj : IDataObject) : HRESULT; stdcall; begin Result := E_NOTIMPL; end;function TCustomRichEdit2.GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall; const MK_ALT = $20; begin pdwEffect := 0; if(fDrag=True) then begin pdwEffect := DROPEFFECT_SCROLL or DROPEFFECT_COPY or DROPEFFECT_MOVE; end else begin if(MK_CONTROL and grfKeyState) = MK_CONTROL then pdwEffect := pdwEffect or DROPEFFECT_COPY else pdwEffect := pdwEffect or DROPEFFECT_MOVE; end; Result := S_OK; end;function TCustomRichEdit2.GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall; var pt : TPoint; Handled : Boolean; begin Handled := False; GetCursorPos(pt); if Assigned(OnContextPopup) then begin Handled := False; OnContextPopup(Self, pt, Handled); end; if not Handled and Assigned(PopupMenu) then PopupMenu.Popup(pt.X, pt.Y); Result := E_NOTIMPL; end;procedure Register; begin RegisterComponents('Win32', [TRichEdit2]); end;end. 自己建个包，添加这3个文件
Copyright (C) 2001, Windoze, [email protected] This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as published
by the Free Software Foundation; either version 2 of the License, or
(at your option) any later version. This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Library Public License for more details. You should have received a copy of the GNU Library General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}{
RICHOLE.PAS
Purpose:
OLE Extensions to the Rich Text Editor
}
{
Translated CPP header file, this file was NOT well-formed for C++ Builder.
Don't use it under such environment unless you modified it properly.
}unit RichOle;interfaceuses
Windows, Messages, SysUtils, Classes, RichEdit, ActiveX;const
// IID
IID_IRichEditOle : TGUID = '{00020D00-0000-0000-C000-000000000046}';
IID_IRichEditOleCallback : TGUID = '{00020D03-0000-0000-C000-000000000046}';// Flags to specify which interfaces should be returned in the structure above
REO_GETOBJ_NO_INTERFACES = $00000000;
REO_GETOBJ_POLEOBJ = $00000001;
REO_GETOBJ_PSTG = $00000002;
REO_GETOBJ_POLESITE = $00000004;
REO_GETOBJ_ALL_INTERFACES = $00000007;// Place object at selection
REO_CP_SELECTION = -1;// Use character position to specify object instead of index
REO_IOB_SELECTION = -1;
REO_IOB_USE_CP = -2;// Object flags
REO_NULL = $00000000; // No flags
REO_READWRITEMASK = $0000003F; // Mask out RO bits
REO_DONTNEEDPALETTE = $00000020; // Object doesn't need palette
REO_BLANK = $00000010; // Object is blank
REO_DYNAMICSIZE = $00000008; // Object defines size always
REO_INVERTEDSELECT = $00000004; // Object drawn all inverted if sel
REO_BELOWBASELINE = $00000002; // Object sits below the baseline
REO_RESIZABLE = $00000001; // Object may be resized
REO_LINK = $80000000; // Object is a link (RO)
REO_STATIC = $40000000; // Object is static (RO)
REO_SELECTED = $08000000; // Object selected (RO)
REO_OPEN = $04000000; // Object open in its server (RO)
REO_INPLACEACTIVE = $02000000; // Object in place active (RO)
REO_HILITED = $01000000; // Object is to be hilited (RO)
REO_LINKAVAILABLE = $00800000; // Link believed available (RO)
REO_GETMETAFILE = $00400000; // Object requires metafile (RO)// flags for IRichEditOle::GetClipboardData(),
// IRichEditOleCallback::GetClipboardData() and
// IRichEditOleCallback::QueryAcceptData()
RECO_PASTE = $00000000; // paste from clipboard
RECO_DROP = $00000001; // drop
RECO_COPY = $00000002; // copy to the clipboard
RECO_CUT = $00000003; // cut to the clipboard
RECO_DRAG = $00000004; // dragtype
LONG=Integer;// Structure passed to GetObject and InsertObject
_reobject = packed record
cbStruct : DWORD;
cp : LONG;
clsid : TGUID;
poleobject : IOleObject;
pstg : IStorage;
polesite : IOleClientSite;
sizel : SIZE;
dvaspect : DWORD;
dwFlags : DWORD;
dwUser : DWORD;
end; REOBJECT=_reobject;
PREOBJECT=^REOBJECT;
LPREOBJECT=PREOBJECT;
IRichEditOle = interface(IUnknown)
['{00020D00-0000-0000-C000-000000000046}']
function GetClientSite(out lplpolesite : IOleClientSite) : HRESULT; stdcall;
function GetObjectCount : LONG; stdcall;
function GetLinkCount : LONG; stdcall;
function GetObject(iob : LONG; var lpreobject : REOBJECT; dwFlags : DWORD) : HRESULT; stdcall;
function InsertObject(var lpreobject : REOBJECT) : HRESULT; stdcall;
function ConvertObject(iob : LONG; rclsidNew : TGUID; lpsreUserTypeNew : LPCSTR) : HRESULT; stdcall;
function ActivateAs(rclsid : TGUID; rclsidAs : TGUID) : HRESULT; stdcall;
function SetHostNames(lpstrContainerApp : LPCSTR; lpstrContainerObj : LPCSTR) : HRESULT; stdcall;
function SetLinkAvailable(iob : LONG; fAvailable : BOOL) : HRESULT; stdcall;
function SetDvaspect(iob : LONG; dvaspect : DWORD) : HRESULT; stdcall;
function HandsOffStorage(iob : LONG) : HRESULT; stdcall;
function SaveCompleted(iob : LONG; lpstg : IStorage) : HRESULT; stdcall;
function InPlaveDeactivate : HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall;
function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD; out lplpdataobj : IDataObject) : HRESULT; stdcall;
function ImportDataObject(out lpdataobj : IDataObject; cf : TClipFormat; hMetaPict : HGLOBAL) : HRESULT; stdcall;
end; IRichEditOleCallback = interface(IUnknown)
['{00020D03-0000-0000-C000-000000000046}']
function GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall;
function GetInPlaceContext(out lplpFrame : IOleInplaceFrame;
out lplpDoc : IOleInplaceUIWindow;
var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall;
function ShowContainerUI(fShow : BOOL) : HRESULT; stdcall;
function QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall;
function DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall;
function QueryAcceptData(lpoleobj : IOleObject;
var lpcfFormat : TClipFormat;
reco : DWORD;
fReally : BOOL;
hMetaPict : HGLOBAL) : HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall;
function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD;
out lplpdataobj : IDataObject) : HRESULT; stdcall;
function GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall;
function GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall;
end; PRICHEDITOLECALLBACK = ^IRichEditOleCallback;
LPRICHEDITOLECALLBACK = PRICHEDITOLECALLBACK;implementationend.
Copyright (C) 2001, Windoze, [email protected] This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as published
by the Free Software Foundation; either version 2 of the License, or
(at your option) any later version. This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Library Public License for more details. You should have received a copy of the GNU Library General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}{
RICHEDITOR2EDITOR.PAS
Purpose:
Component editor for TRichEdit2
}
unit RichEdit2Editor;interface{
If you have Win2KDlg components, you can enable this option.
Ok, forget it :)
}
{.$DEFINE USES_WIN2KDLG}uses
Windows, Sysutils, Messages, ComObj, Classes, Controls, ActiveX, ComCtrls,
RichEdit2, RichOle, dsgnintf, shellapi, Dialogs
{$IFDEF USES_WIN2KDLG}
,Win2KDlg
{$ENDIF}
;type
TRichEdit2Editor = class(TComponentEditor)
function GetVerbCount : Integer; override;
function GetVerb(Index : Integer) : string; override;
procedure ExecuteVerb(Index : Integer); override;
procedure Edit; override; procedure EditRichEditContent(re : TRichEdit2);
procedure LoadRichTextFile(re : TRichEdit2);
procedure Clear(re : TRichEdit2);
end; procedure Register;implementationfunction TRichEdit2Editor.GetVerbCount : Integer;
begin
Result := (inherited GetVerbCount) + 3;
end;function TRichEdit2Editor.GetVerb(Index : Integer) : string;
begin
if Index < (inherited GetVerbCount) then
Result := inherited GetVerb(Index)
else if Index = inherited GetVerbCount then
Result := 'Edit...'
else if Index = (inherited GetVerbCount)+1 then
Result := 'Load File'
else if Index = (inherited GetVerbCount)+2 then
Result := 'Clear';
end;procedure TRichEdit2Editor.ExecuteVerb(Index : Integer);
begin
if Index < inherited GetVerbCount then
inherited
else if Index = inherited GetVerbCount then
EditRichEditContent(Component as TRichEdit2)
else if Index = (inherited GetVerbCount)+1 then
LoadRichTextFile(Component as TRichEdit2)
else if Index = (inherited GetVerbCount)+2 then
Clear(Component as TRichEdit2)
end;procedure TRichEdit2Editor.Edit;
begin
EditRichEditContent(Component as TRichEdit2);
end;{
This is a quick-and-dirty content editor, simply save to a temporary file
and run associated program to edit saved file, then reload the file into
control.
}
procedure TRichEdit2Editor.EditRichEditContent(re : TRichEdit2); function MakeTempFileName : string;
var
pszTempDir : PChar;
pszFileName : PChar;
begin
pszTempDir := AllocMem(MAX_PATH);
pszFileName := AllocMem(MAX_PATH);
GetTempPath(MAX_PATH, pszTempDIr);
// I've to create a new file to get a temporary file name :(
GetTempFileName(pszTempDir, 'tnt', 0, pszFileName);
Result := pszFileName;
// Delete created file, we need only a file name
DeleteFile(Result);
FreeMem(pszTempDir);
FreeMem(pszFileName);
end;
var
fn : string;
fs : TFileStream;
se : SHELLEXECUTEINFO;
begin
if re.PlainText then
fn := MakeTempFileName + '.txt'
else
fn := MakeTempFileName + '.rtf';
fs := TFileStream.Create(fn, fmCreate);
re.SaveToStream(fs, re.PlainText);
fs.Free;
se.cbSize := SizeOf(se);
se.fMask := SEE_MASK_NOCLOSEPROCESS;
se.Wnd := re.Handle;
se.lpVerb := nil;
se.lpFile := PChar(fn);
se.lpParameters := nil;
se.lpDirectory := '.';
se.nShow := SW_SHOW;
ShellExecuteEx(@se);
// Wait until program closed
WaitForSingleObject(se.hProcess, INFINITE);
fs := TFileStream.Create(fn, fmOpenRead);
re.LoadFromStream(fs, re.PlainText);
fs.Free;
DeleteFile(fn);
// Since the 'Data' property is NOT a real property, we've to
// call IFormDesigner.Modified manually
GetDesigner.Modified;
end;procedure TRichEdit2Editor.LoadRichTextFile(re : TRichEdit2);
var
{$IFDEF USES_WIN2KDLG}
dlg : TOpenDialogEx;
{$ELSE}
dlg : TOpenDialog;
{$ENDIF}
fs : TFileStream;
begin
{$IFDEF USES_WIN2KDLG}
dlg := TOpenDialogEx.Create(re.Owner);
dlg.ShowPlacesBar := True;
{$ELSE}
dlg := TOpenDialog.Create(re.Owner);
{$ENDIF}
if re.PlainText then
dlg.Filter := 'Text Files(*.txt)|*.TXT|All Files(*.*)|*.*|'
else
dlg.Filter := 'RTF Files(*.rtf)|*.RTF|All Files(*.*)|*.*|';
dlg.FilterIndex := 1;
dlg.Options := [ofHideReadOnly,ofShowHelp,ofPathMustExist,ofFileMustExist,ofEnableSizing];
if dlg.Execute then
begin
fs := TFileStream.Create(dlg.FileName, fmOpenRead);
re.LoadFromStream(fs, re.PlainText);
fs.Free;
GetDesigner.Modified;
end;
dlg.Free;
end;procedure TRichEdit2Editor.Clear(re : TRichEdit2);
begin
re.Clear;
end;procedure Register;
begin
RegisterComponentEditor(TCustomRichEdit2, TRichEdit2Editor);
end;end.
Remove prior dot to enable OLE Inplace activation Unfortunately, current implementation of inplace-activation still buggy,
sometimes inserted object cannot update properly, so you'd better don't
enable this feature...
}
{.$DEFINE USES_IPACTIVATE}{
Remove prior dot to add a TextDocument property, with this you can
access an ITOMDocument interface owned by the richedit control.
You must generate tom_TLB.pas/dcr from you riched20.dll, I don't
supply this file to avoid version conflict.
}
{.$DEFINE USES_TOM}uses
Windows, Messages, ComObj, Classes, Controls, ActiveX, ComCtrls, ComStrs,
RichEdit, RichOle, Graphics, SysUtils, forms
{$IFDEF USES_IPACTIVATE}
, olectnrs
{$ENDIF}{$IFDEF USES_TOM}
, tom_TLB
{$ENDIF}
;const
EM_GETZOOM = (WM_USER + 224);
EM_SETZOOM = (WM_USER + 225);type
TRichEditLinkNotify = procedure(Sender: TObject;
StartPos, EndPos: Integer; NotifyMessage : Longint; var Handled: Boolean) of object; TRichEditMargin = class(TPersistent)
protected
FRECtrl : TCustomRichEdit;
FWidth : Integer;
FUseFontInfo : Boolean;
FDirect : Boolean; // True = Left, False = Right
FPlainTextMode : Boolean;
procedure SetWidth(AWidth : Integer);
procedure SetUseFontInfo(AUseFontInfo : Boolean);
procedure SetMargin;
property UseFontInfo : Boolean read FUseFontInfo write SetUseFontInfo; public
constructor Create(AOwner : TComponent); virtual;
procedure Assign(Source: TPersistent); override; published
property Width : Integer read FWidth write SetWidth;
end; TCustomRichEdit2 = class(TCustomRichEdit, IRichEditOleCallback)
private
REObject : IRichEditOle;
FLeftMargin, FRightMargin : TRichEditMargin;
FLinkNotify : TRichEditLinkNotify;
FPlainTextMode : Boolean;
FLines : TStrings;
ReloadStream : TMemoryStream;
{$IFDEF USES_TOM}
TOMDocument : ITextDocument;
{$ENDIF}
protected
// Interface methods
// *** IRichEditOleCallback methods ***
function GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall;
function GetInPlaceContext(out lplpFrame : IOleInplaceFrame;
out lplpDoc : IOleInplaceUIWindow;
var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall;
function ShowContainerUI(fShow : BOOL) : HRESULT; stdcall;
function QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall;
function DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall;
function QueryAcceptData(lpoleobj : IOleObject;
var lpcfFormat : TClipFormat;
reco : DWORD;
fReally : BOOL;
hMetaPict : HGLOBAL) : HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall;
function GetClipboardData(var lpchrg : CHARRANGE; reco : DWORD;
out lplpdataobj : IDataObject) : HRESULT; stdcall;
function GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall;
function GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall; // Message functions
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
function SaveClipboard(NumObj, NumChars: Integer): Boolean;
function ProtectChange(StartPos, EndPos: Integer): Boolean;
function LinkNotify(StartPos, EndPos: Integer; NotifyMessage : Longint): Boolean; // Virtual functions
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override; function ReadFromStream(Stream : TStream; var Buffer; var Count : Longint) : Longint; virtual;
function WriteToStream(Stream : TStream; const Buffer; var Count : Longint) : Longint; virtual;
procedure DefineProperties(Filer: TFiler); override; procedure ReadData(Stream : TStream);
procedure WriteData(Stream : TStream); // Properties;
function GetAutoURLDetect : Boolean;
procedure SetAutoURLDetect(FActive : Boolean);
function GetCanRedo : Boolean;
procedure SetSelectionVisible(FVisible : Boolean);
function GetZoomRatio : Real;
procedure SetZoomRatio(AZoomRatio : Real);
procedure SetPlainTextMode(ATextMode : Boolean);
procedure SetLines(Value: TStrings);{$IFDEF USES_TOM}
function GetTOMDocument : ITextDocument;
function UndoEx(Count : Longint) : Longint;
function RedoEx(Count : Longint) : Longint;
{$ENDIF}
public
constructor Create(AOwner : TComponent); override;
procedure DestroyWnd; override;
destructor Destroy; override;
// Methods
procedure Clear; override;
procedure LoadFromStream(Stream : TStream; FromText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False);
procedure SaveToStream(Stream : TStream; ToText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False);
procedure Redo;
function CanPaste(ClipboardFormat : WORD=0) : Boolean;
// Properties
property CanRedo : Boolean read GetCanRedo;
property SelectionVisible : Boolean write SetSelectionVisible;
property AutoURLDetect : Boolean read GetAutoURLDetect write SetAutoURLDetect;
property LeftMargin : TRichEditMargin read FLeftMargin write FLeftMargin;
property RightMargin : TRichEditMargin read FRightMargin write FRightMargin;
property ZoomRatio : Real read GetZoomRatio write SetZoomRatio;
{$IFDEF USES_TOM}
property TextDocument : ITextDocument read GetTOMDocument;
{$ENDIF} // Changed, not fully implemented, yet
property PlainText : Boolean read FPlainTextMode write SetPlainTextMode; // Events
property OnLinkNotify : TRichEditLinkNotify read FLinkNotify write FLinkNotify;
property Lines read FLines write SetLines;
published
end; TRichEdit2 = class(TCustomRichEdit2)
published
property Align;
property Alignment;
property Anchors;
property AutoURLDetect;
property BiDiMode;
property BorderStyle;
property BorderWidth;
property Color;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property HideScrollBars;
property ImeMode;
property ImeName;
property Constraints;
property Lines;
property MaxLength;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PlainText;
property PopupMenu;
property ReadOnly;
property ScrollBars;
property ShowHint;
property TabOrder;
property TabStop default True;
property Visible;
property WantTabs;
property WantReturns;
property WordWrap;
property LeftMargin;
property RightMargin;
property ZoomRatio;
property OnChange;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnProtectChange;
property OnResizeRequest;
property OnSaveClipboard;
property OnSelectionChange;
property OnStartDock;
property OnStartDrag;
property OnLinkNotify;
end;{
Need a TDBRichEdit2? Do it youself. :)
Maybe you've to use a BLOB field to store data...
}
// Copy from VCL source and remove some members
TRichEdit2Strings = class(TStrings)
private
RichEdit: TCustomRichEdit2;
procedure EnableChange(const Value: Boolean);
protected
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
procedure Put(Index: Integer; const S: string); override;
procedure SetUpdateState(Updating: Boolean); override;
procedure SetTextStr(const Value: string); override;
public
procedure Clear; override;
procedure AddStrings(Strings: TStrings); override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
end;procedure TRichEdit2Strings.AddStrings(Strings: TStrings);
var
SelChange: TNotifyEvent;
begin
SelChange := RichEdit.OnSelectionChange;
RichEdit.OnSelectionChange := nil;
try
inherited AddStrings(Strings);
finally
RichEdit.OnSelectionChange := SelChange;
end;
end;function TRichEdit2Strings.GetCount: Integer;
begin
Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;function TRichEdit2Strings.Get(Index: Integer): string;
var
Text: array[0..4095] of Char;
L: Integer;
begin
Word((@Text)^) := SizeOf(Text);
L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
SetString(Result, Text, L);
end;procedure TRichEdit2Strings.Put(Index: Integer; const S: string);
var
Selection: TCharRange;
begin
if Index >= 0 then
begin
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := Selection.cpMin +
SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
end;
end;
end;procedure TRichEdit2Strings.Insert(Index: Integer; const S: string);
var
L: Integer;
Selection: TCharRange;
Fmt: PChar;
Str: string;
begin
if Index >= 0 then
begin
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin >= 0 then Fmt := '%s'#13#10
else begin
Selection.cpMin :=
SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
if Selection.cpMin < 0 then Exit;
L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
if L = 0 then Exit;
Inc(Selection.cpMin, L);
Fmt := #13#10'%s';
end;
Selection.cpMax := Selection.cpMin;
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
Str := Format(Fmt, [S]);
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));{
Removed
if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
raise EOutOfResources.Create(sRichEditInsertError);
}
end;
end;procedure TRichEdit2Strings.Delete(Index: Integer);
const
Empty: PChar = '';
var
Selection: TCharRange;
begin
if Index < 0 then Exit;
Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
if Selection.cpMin <> -1 then
begin
Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0);
if Selection.cpMax = -1 then
Selection.cpMax := Selection.cpMin +
SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
end;
end;procedure TRichEdit2Strings.Clear;
begin
RichEdit.Clear;
end;procedure TRichEdit2Strings.SetUpdateState(Updating: Boolean);
begin
if RichEdit.Showing then
SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
if not Updating then begin
RichEdit.Refresh;
RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
end;
end;procedure TRichEdit2Strings.EnableChange(const Value: Boolean);
var
EventMask: Longint;
begin
with RichEdit do
begin
if Value then
EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
else
EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
end;
end;procedure TRichEdit2Strings.SetTextStr(const Value: string);
begin
EnableChange(False);
try
inherited SetTextStr(Value);
finally
EnableChange(True);
end;
end;{
procedure TRichEdit2Strings.LoadFromStream(Stream: TStream);
begin
raise Exception.Create('Not implemented function');
end;procedure TRichEdit2Strings.SaveToStream(Stream: TStream);
begin
raise Exception.Create('Not implemented function');
end;procedure TRichEdit2Strings.LoadFromFile(const FileName: string);
begin
raise Exception.Create('Not implemented function');
end;procedure TRichEdit2Strings.SaveToFile(const FileName: string);
begin
raise Exception.Create('Not implemented function');
end;
}constructor TRichEditMargin.Create(AOwner : TComponent);
begin
FWidth := 4;
FUseFontInfo := False;
end;procedure TRichEditMargin.Assign(Source : TPersistent);
begin
FWidth := (Source as TRichEditMargin).FWidth;
FUseFontInfo := (Source as TRichEditMargin).FUseFontInfo;
end;procedure TRichEditMargin.SetMargin;
var
wParam : DWORD;
lParam : DWORD;
begin
if FDirect then
begin
// Left margin
wParam := EC_LEFTMARGIN;
lParam := FWidth;
if FUseFontInfo then
begin
wParam := wParam or EC_USEFONTINFO;
lParam := EC_USEFONTINFO;
end;
end
else
begin
// Right margin
wParam := EC_RIGHTMARGIN;
lParam := FWidth shl 16;
if FUseFontInfo then
begin
wParam := wParam or EC_USEFONTINFO;
lParam := $FFFF0000;
end;
end;
SendMessage(FRECtrl.Handle, EM_SETMARGINS, wParam, lParam);
end;procedure TRichEditMargin.SetWidth(AWidth : Integer);
begin
FWidth := AWidth;
SetMargin;
end;procedure TRichEditMargin.SetUseFontInfo(AUseFontInfo : Boolean);
begin
FUseFontInfo := AUseFontInfo;
SetMargin;
end;constructor TCustomRichEdit2.Create(AOwner : TComponent);
begin
inherited;
FPlainTextMode := False;
LeftMargin := TRichEditMargin.Create(Self);
LeftMargin.FRECtrl := Self;
LeftMargin.FDirect := True;
RightMargin := TRichEditMargin.Create(Self);
RightMargin.FRECtrl := Self;
RightMargin.FDirect := False;
FLines := TRichEdit2Strings.Create;
TRichEdit2Strings(FLines).RichEdit := Self;
end;
destructor TCustomRichEdit2.Destroy;
begin
LeftMargin.Free;
RightMargin.Free;
inherited;
end;procedure TCustomRichEdit2.CreateParams(var Params: TCreateParams);
begin
inherited;
CreateSubClass(Params, 'RICHEDIT20A');
with Params do
begin
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;procedure TCustomRichEdit2.CreateWnd;
var
pI : IRichEditOleCallback;
begin
inherited; SendMessage(Handle, WM_SETFONT, Font.Handle, 0); pI := Self;
SendMessage(Handle, EM_SETOLECALLBACK, 0, Integer(Pointer(pI)));
SendMessage(Handle, EM_SETEVENTMASK, 0,
ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
ENM_PROTECTED or ENM_LINK);
LeftMargin.SetMargin;
RightMargin.SetMargin; // Some properties' changing will re-create the window, to keep the content
// we have to save and reload. // Reload data if needed
if ReloadStream <> nil then
begin
ReloadStream.Position := 0;
LoadFromStream(ReloadStream);
ReloadStream.Free;
ReloadStream := nil;
end;end;procedure TCustomRichEdit2.DestroyWnd;
begin
// Release interfaces
if REObject<>nil then
begin
REObject := nil;
end;
{$IFDEF USES_TOM}
if TOMDocument<>nil then
begin
TOMDocument := nil;
end;
{$ENDIF} // Tempororally save data if needed
if not (csDestroying in ComponentState) then
begin
ReloadStream := TMemoryStream.Create;
SaveToStream(ReloadStream);
end; inherited;
end;type
PENLink = ^TENLink;procedure TCustomRichEdit2.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineBinaryProperty('Data', ReadData, WriteData, True);
end;procedure TCustomRichEdit2.ReadData(Stream : TStream);
var
Size : Longint;
TempStream : TMemoryStream;
begin
TempStream := TMemoryStream.Create;
try
Stream.ReadBuffer(Size, SizeOf(Size));
if Size>0 then
begin
TempStream.CopyFrom(Stream, Size);
TempStream.position:= 0;
LoadFromStream(TempStream);
end;
finally
TempStream.Free;
end;
end;procedure TCustomRichEdit2.WriteData(Stream : TStream);
var
Size : Longint;
TempStream : TMemoryStream;
begin
TempStream := TMemoryStream.Create;
try
SaveToStream(TempStream);
TempStream.position:= 0;
Size:= TempStream.Size;
Stream.WriteBuffer(Size, SizeOf(Size));
if Size>0 then
Stream.WriteBuffer(PChar(TempStream.Memory)^, Size);
finally
TempStream.free;
end;
end;// Copy from VCL, mostly
procedure TCustomRichEdit2.CNNotify(var Message: TWMNotify);
begin
with Message do
case NMHdr^.code of
EN_SELCHANGE: SelectionChange;
EN_REQUESTRESIZE: RequestSize(PReqSize(NMHdr)^.rc);
EN_SAVECLIPBOARD:
with PENSaveClipboard(NMHdr)^ do
if not SaveClipboard(cObjectCount, cch) then Result := 1;
EN_PROTECTED:
with PENProtected(NMHdr)^.chrg do
if not ProtectChange(cpMin, cpMax) then Result := 1;
EN_LINK:
with PENLink(NMHdr)^.chrg do
if LinkNotify(cpMin, cpMax, PENLink(NMHdr)^.msg) then Message.Result := 1;
end;
end;// Copy from VCL
function TCustomRichEdit2.SaveClipboard(NumObj, NumChars: Integer): Boolean;
begin
Result := True;
if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result);
end;// Copy from VCL
function TCustomRichEdit2.ProtectChange(StartPos, EndPos: Integer): Boolean;
begin
Result := False;
if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result);
end;function TCustomRichEdit2.LinkNotify(StartPos, EndPos: Integer; NotifyMessage : Longint): Boolean;
begin
Result := False;
if Assigned(OnLinkNotify) then OnLinkNotify(Self, StartPos, EndPos, NotifyMessage, Result);
end;function TCustomRichEdit2.GetAutoURLDetect;
begin
Result := Perform(EM_GETAUTOURLDETECT, 0, 0)=1;
end;procedure TCustomRichEdit2.SetAutoURLDetect(FActive : Boolean);
begin
SendMessage(Handle, EM_AUTOURLDETECT, Integer(FActive), 0);
end;function TCustomRichEdit2.GetZoomRatio : Real;
var
numerator, denominator : WORD;
begin
SendMessage(Handle, EM_GETZOOM, Longint(@numerator), Longint(@denominator));
if (denominator=0) or (numerator=0) then
Result := 1
else
Result := numerator/denominator;
end;procedure TCustomRichEdit2.SetZoomRatio(AZoomRatio : Real);
var
numerator, denominator : DWORD;
begin
denominator := 100;
numerator := Round(AZoomRatio * 100);
SendMessage(Handle, EM_SETZOOM, numerator, denominator);
end;procedure TCustomRichEdit2.SetPlainTextMode(ATextMode : Boolean);
var
cf2 : CHARFORMAT2;
begin
cf2.cbSize := SizeOf(cf2);
cf2.dwMask := CFM_BACKCOLOR or CFM_CHARSET or CFM_COLOR
or CFM_FACE or CFM_SIZE or CFM_UNDERLINETYPE or CFM_WEIGHT;
cf2.dwEffects := 0;
cf2.yHeight := -(Font.Height) * 1440 div Font.PixelsPerInch;
cf2.yOffset := 0;
cf2.crTextColor := Font.Color;
cf2.bCharSet := Font.Charset;
case Font.Pitch of
fpDefault:
cf2.bPitchAndFamily := DEFAULT_PITCH;
fpFixed:
cf2.bPitchAndFamily := FIXED_PITCH;
fpVariable:
cf2.bPitchAndFamily := VARIABLE_PITCH;
end;
StrLCopy(cf2.szFaceName, PChar(Font.Name), 31);
if fsBold in Font.Style then
cf2.wWeight := FW_BOLD
else
cf2.wWeight := FW_NORMAL;
if fsUnderLine in Font.Style then
cf2.bUnderlineType := CFU_UNDERLINE
else
cf2.bUnderlineType := CFU_UNDERLINENONE;
cf2.crBackColor := ColorToRGB(Color);
SendMessage(Handle, EM_SETCHARFORMAT, SCF_ALL, Integer(@cf2));
FPlainTextMode := ATextMode;
end;{$IFDEF USES_TOM}
procedure TCustomRichEdit2.Clear;
begin
TextDocument.New;
end;
{$ELSE}
type
SETTEXTEX=packed record
flags : DWORD;
codepage : UINT;
end;
const
ST_DEFAULT = 0;
ST_KEEPUNDO = 1;
ST_SELECTION = 2;
EM_SETTEXTEX = (WM_USER + 97);
procedure TCustomRichEdit2.Clear;
var
st : SETTEXTEX;
ch : Char;
begin
st.flags := ST_DEFAULT;
st.codepage := CP_ACP;
ch := #0;
SendMessage(Handle, EM_SETTEXTEX, Integer(@st), Integer(@ch));
end;
{$ENDIF}function TCustomRichEdit2.GetCanRedo : Boolean;
begin
Result := Perform(EM_CANREDO, 0, 0)<>0;
end;procedure TCustomRichEdit2.Redo;
begin
SendMessage(Handle, EM_REDO, 0, 0);
end;{$IFDEF USES_TOM}
function TCustomRichEdit2.UndoEx(Count : Longint) : Longint;
begin
Result := TextDocument.Undo(Count);
end;function TCustomRichEdit2.RedoEx(Count : Longint) : Longint;
begin
Result := TextDocument.Redo(Count);
end;
{$ENDIF}
function TCustomRichEdit2.CanPaste(ClipboardFormat : WORD=0) : Boolean;
begin
Result := SendMessage(Handle, EM_CANPASTE, ClipboardFormat, 0) <> 0;
end;procedure TCustomRichEdit2.SetSelectionVisible(FVisible : Boolean);
begin
SendMessage(Handle, EM_HIDESELECTION, Longint(not FVisible), 0);
end;{$IFDEF USES_TOM}
function TCustomRichEdit2.GetTOMDocument : ITextDocument;
begin
if TOMDocument=nil then
begin
SendMessage(Handle, EM_GETOLEINTERFACE, 0, Longint(@REObject));
TOMDocument := REObject as ITextDocument;
end;
Result := TOMDocument;
end;
{$ENDIF}procedure TCustomRichEdit2.SetLines(Value: TStrings);
begin
FLines.Assign(Value);
end;// EM_STREAMIN/OUT implementations
type
TRichEditExCallback = record
RichEditEx : TCustomRichEdit2;
Stream : TStream;
FRead : Boolean;
end;
PRichEditExCallback = ^TRichEditExCallback;function RichEditExStreamCallback(dwCookie: Longint; pbBuff: PByte;
cb: Longint; var pcb: Longint): Longint; stdcall;
var
pCallBack : PRichEditExCallback;
begin
pCallBack := PRichEditExCallback(dwCookie);
pcb := cb;
if pCallBack^.FRead then
Result := pCallBack^.RichEditEx.ReadFromStream(pCallBack^.Stream, pbBuff^, pcb)
else
Result := pCallBack^.RichEditEx.WriteToStream(pCallBack^.Stream, pbBuff^, pcb);
end;procedure TCustomRichEdit2.LoadFromStream(Stream : TStream; FromText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False);
var
es : TEditStream;
cb : TRichEditExCallback;
Options : Longint;
begin
cb.Stream := Stream;
cb.RichEditEx := Self;
cb.FRead := True;
es.dwCookie := Longint(@cb);
es.dwError := 0;
es.pfnCallback := RichEditExStreamCallback; // prepare options
Options := 0;
if FromText then
Options := Options or SF_TEXT
else
Options := Options or SF_RTF;
if Selection then
Options := Options or SFF_SELECTION;
if Unicode then
Options := Options or SF_UNICODE; SendMessage(Handle, EM_STREAMIN, Options, Longint(@es)); // Check result
if es.dwError<>0 then
raise EReadError.CreateFmt('%s.LoadFromStream error, Error code is %d', [Name, es.dwError]);
end;procedure TCustomRichEdit2.SaveToStream(Stream : TStream; ToText : Boolean=False; Selection : Boolean=False; Unicode : Boolean=False);
var
es : TEditStream;
cb : TRichEditExCallback;
Options : Longint;
begin
cb.Stream := Stream;
cb.RichEditEx := Self;
cb.FRead := False;
es.dwCookie := Longint(@cb);
es.dwError := 0;
es.pfnCallback := RichEditExStreamCallback;
// prepare options
Options := 0;
if ToText then
Options := Options or SF_TEXT
else
Options := Options or SF_RTF;
if Selection then
Options := Options or SFF_SELECTION;
if Unicode then
Options := Options or SF_UNICODE; SendMessage(Handle, EM_STREAMOUT, Options, Longint(@es)); // Check result
if es.dwError<>0 then
raise EReadError.CreateFmt('%s.SaveToStream error, Error code is %d', [Name, es.dwError]);
end;function TCustomRichEdit2.ReadFromStream(Stream : TStream; var Buffer; var Count : Longint) : Longint;
begin
Count := Stream.Read(Buffer, Count);
Result := 0;
end;function TCustomRichEdit2.WriteToStream(Stream : TStream; const Buffer; var Count : Longint) : Longint;
begin
Count := Stream.Write(Buffer, Count);
Result := 0;
end;// *** IRichEditOleCallback methods ***
function TCustomRichEdit2.GetNewStorage(out lplpstg : IStorage) : HRESULT; stdcall;
var
LockBytes: ILockBytes;
begin
Result := E_NOTIMPL;
if FPlainTextMode then Exit;
Result:= S_OK;
try
OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE
or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, lplpstg));
except
Result:= E_OUTOFMEMORY;
end;
end;
{$IFDEF USES_IPACTIVATE}
// Copy from VCL
function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
begin
if Form.OleFormObject = nil then TOleForm.Create(Form);
Result := Form.OleFormObject as IVCLFrameForm;
end;// Copy from VCL
function IsFormMDIChild(Form: TCustomForm): Boolean;
begin
Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild);
end;
{$ENDIF}function TCustomRichEdit2.GetInPlaceContext(out lplpFrame : IOleInplaceFrame;
out lplpDoc : IOleInplaceUIWindow;
var lpFrameInfo : OLEINPLACEFRAMEINFO) : HRESULT; stdcall;
begin
{$IFDEF USES_IPACTIVATE}
lplpDoc := GetVCLFrameForm(ValidParentForm(Owner as TControl));
lplpFrame := lplpDoc as IOleInplaceFrame;
if IsFormMDIChild(GetVCLFrameForm(ValidParentForm(Owner as TControl)).Form) then
begin
lplpFrame := GetVCLFrameForm(Application.MainForm);
end; with lpFrameInfo do
begin
cb := sizeof(lpFrameInfo);
fMDIApp := False;
lplpFrame.GetWindow(hWndFrame);
hAccel := 0;
cAccelEntries := 0;
end;
lpFrameInfo := lpFrameInfo; Result:= S_OK;
{$ELSE}
Result := E_NOTIMPL;
{$ENDIF}
end;function TCustomRichEdit2.ShowContainerUI(fShow : BOOL) : HRESULT; stdcall;
begin
{$IFDEF USES_IPACTIVATE}
if fShow then
with GetVCLFrameForm(ValidParentForm(Owner as TControl)) do
begin
SetMenu(0, 0, 0);
ClearBorderSpace;
end;
{$ENDIF}
Result := S_OK;
end;function TCustomRichEdit2.QueryInsertObject(var lpclsid : TGUID; lpstg : IStorage; cp : LONG) : HRESULT; stdcall;
begin
Result := S_OK;
if FPlainTextMode then
begin
Result := S_FALSE;
Exit;
end;
end;function TCustomRichEdit2.DeleteObject(lpoleobj : IOleObject) : HRESULT; stdcall;
begin
Result := S_OK;
end;function TCustomRichEdit2.QueryAcceptData(lpoleobj : IOleObject;
var lpcfFormat : TClipFormat;
reco : DWORD;
fReally : BOOL;
hMetaPict : HGLOBAL) : HRESULT; stdcall;
begin
if FPlainTextMode then
lpcfFormat := CF_TEXT;
Result := S_OK;
end;function TCustomRichEdit2.ContextSensitiveHelp(fEnterMode : BOOL) : HRESULT; stdcall;
begin
Result := E_NOTIMPL;
end;function TCustomRichEdit2.GetClipboardData(var lpchrg : CHARRANGE;
reco : DWORD;
out lplpdataobj : IDataObject) : HRESULT; stdcall;
begin
Result := E_NOTIMPL;
end;function TCustomRichEdit2.GetDragDropEffect(fDrag : BOOL; grfKeyState : DWORD; var pdwEffect : DWORD) : HRESULT; stdcall;
const
MK_ALT = $20;
begin
pdwEffect := 0;
if(fDrag=True) then
begin
pdwEffect := DROPEFFECT_SCROLL or DROPEFFECT_COPY or DROPEFFECT_MOVE;
end
else
begin
if(MK_CONTROL and grfKeyState) = MK_CONTROL then
pdwEffect := pdwEffect or DROPEFFECT_COPY
else
pdwEffect := pdwEffect or DROPEFFECT_MOVE;
end;
Result := S_OK;
end;function TCustomRichEdit2.GetContextMenu(seltype : WORD; lpoleobj : IOleObject; var lpchrg : CHARRANGE; var lphmenu : HMENU) : HRESULT; stdcall;
var
pt : TPoint;
Handled : Boolean;
begin
Handled := False;
GetCursorPos(pt);
if Assigned(OnContextPopup) then
begin
Handled := False;
OnContextPopup(Self, pt, Handled);
end;
if not Handled and Assigned(PopupMenu) then
PopupMenu.Popup(pt.X, pt.Y);
Result := E_NOTIMPL;
end;procedure Register;
begin
RegisterComponents('Win32', [TRichEdit2]);
end;end.
自己建个包，添加这3个文件