Created
December 15, 2011 17:39
-
-
Save rkennedy/1482014 to your computer and use it in GitHub Desktop.
Using the windowsless RTF control from Delphi: http://www.cs.wisc.edu/~rkennedy/windowless-rtf
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| // Demonstration of using TOM.pas, the windowless rich-edit control, and | |
| // the text object model | |
| // http://www.cs.wisc.edu/~rkennedy/windowless-rtf | |
| // Copyright © 2003-2006 Rob Kennedy. Some rights reserved. | |
| // For license information, see http://www.cs.wisc.edu/~rkennedy/license | |
| unit RTFPaint; | |
| interface | |
| uses Windows, Graphics; | |
| // The RTF parameter should be a string containing a full RTF document. It | |
| // will not work if it is just an RTF fragment. | |
| procedure DrawRTF(Canvas: TCanvas; const RTF: string; const Rect: TRect; const Transparent, WordWrap: Boolean); | |
| implementation | |
| uses SysUtils, ComObj, ActiveX, RichEdit, Messages, TOM; | |
| function StrCpyN(dest: PChar; const src: PChar; cchMax: Integer): PChar; stdcall; external 'shlwapi.dll' name 'StrCpyNA'; | |
| function StrCpyNA(dest: PAnsiChar; const src: PAnsiChar; cchMax: Integer): PAnsiChar; stdcall; external 'shlwapi.dll'; | |
| function StrCpyNW(dest: PWideChar; const src: PWideChar; cchMax: Integer): PWideChar; stdcall; external 'shlwapi.dll'; | |
| type | |
| TDrawRTFTextHost = class(TTextHostImpl) | |
| private | |
| FDefaultCharFormat: PCharFormatW; | |
| FDefaultParaFormat: PParaFormat; | |
| FRect: TRect; | |
| FTransparent, FWordWrap: Boolean; | |
| protected | |
| // TTextHostImpl | |
| function TxGetClientRect(out prc: TRect): HResult; override; | |
| function TxGetCharFormat(out ppCF: PCharFormatW): HResult; override; | |
| function TxGetParaFormat(out ppPF: PParaFormat): HResult; override; | |
| function TxGetBackStyle(out pstyle: TTxtBackStyle): HResult; override; | |
| function OnTxCharFormatChange(const pcf: TCharFormatW): HResult; override; | |
| function OnTxParaFormatChange(const ppf: TParaFormat): HResult; override; | |
| function TxGetPropertyBits(dwMask: DWord; out pdwBits: DWord): HResult; override; | |
| function TxNotify(iNotify: DWord; pv: Pointer): HResult; override; | |
| public | |
| constructor Create(const ARect: TRect; const ATransparent, AWordWrap: Boolean); | |
| destructor Destroy; override; | |
| end; | |
| PCookie = ^TCookie; | |
| TCookie = record | |
| dwSize, dwCount: Cardinal; | |
| Text: PChar; | |
| end; | |
| function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall; | |
| var | |
| Cookie: PCookie; | |
| begin | |
| Result := 0; | |
| Cookie := PCookie(dwCookie); | |
| if Cookie.dwSize - Cookie.dwCount < Cardinal(cb) then pcb := Cookie.dwSize - Cookie.dwCount | |
| else pcb := cb; | |
| if pcb <= 0 then exit; | |
| CopyMemory(pbBuff, Cookie.Text, pcb); | |
| Inc(Cookie.dwCount, pcb); | |
| Inc(Cookie.Text, pcb); | |
| end; | |
| procedure DrawRTF(Canvas: TCanvas; const RTF: string; const Rect: TRect; const Transparent, WordWrap: Boolean); | |
| var | |
| Host: ITextHost; | |
| Unknown: IUnknown; | |
| Services: ITextServices; | |
| HostImpl: TTextHostImpl; | |
| Stream: TEditStream; | |
| Cookie: TCookie; | |
| res: Integer; | |
| begin | |
| HostImpl := TDrawRTFTextHost.Create(Rect, Transparent, WordWrap); | |
| Host := CreateTextHost(HostImpl); | |
| OleCheck(CreateTextServices(nil, Host, Unknown)); | |
| Services := Unknown as ITextServices; | |
| Unknown := nil; | |
| PatchTextServices(Services); | |
| Cookie.dwCount := 0; | |
| Cookie.dwSize := Length(RTF); | |
| Cookie.Text := PChar(RTF); | |
| Stream.dwCookie := Integer(@Cookie); | |
| Stream.dwError := 0; | |
| Stream.pfnCallback := EditStreamInCallback; | |
| OleCheck(Services.TxSendMessage(em_StreamIn, sf_RTF or sff_PlainRTF, lParam(@Stream), res)); | |
| OleCheck(Services.TxDraw(dvAspect_Content, 0, nil, nil, Canvas.Handle, 0, Rect, PRect(nil)^, PRect(nil)^, nil, 0, txtView_Inactive)); | |
| Services := nil; | |
| Host := nil; | |
| end; | |
| { TDrawRTFTextHost } | |
| constructor TDrawRTFTextHost.Create(const ARect: TRect; const ATransparent, AWordWrap: Boolean); | |
| begin | |
| inherited Create; | |
| FRect := ARect; | |
| FTransparent := ATransparent; | |
| FWordWrap := AWordWrap; | |
| GetMem(FDefaultCharFormat, SizeOf(FDefaultCharFormat^)); | |
| FillChar(FDefaultCharFormat^, SizeOf(FDefaultCharFormat^), 0); | |
| FDefaultCharFormat.cbSize := SizeOf(FDefaultCharFormat^); | |
| Cardinal(FDefaultCharFormat.dwMask) := cfm_Bold or cfm_Charset or {cfm_Color or} cfm_Face or cfm_Italic or cfm_Offset or cfm_Protected or {cfm_Size or} cfm_Strikeout or cfm_Underline; | |
| FDefaultCharFormat.dwEffects := 0; | |
| FDefaultCharFormat.yHeight := 8 * 20; | |
| FDefaultCharFormat.crTextColor := ColorToRGB(clBlack); | |
| FDefaultCharFormat.bCharSet := Default_Charset; | |
| FDefaultCharFormat.bPitchAndFamily := Default_Pitch or ff_DontCare; | |
| StrCpyNW(FDefaultCharFormat.szFaceName, 'Tahoma', SizeOf(FDefaultCharFormat.szFaceName) div SizeOf(FDefaultCharFormat.szFaceName[0])); | |
| GetMem(FDefaultParaFormat, SizeOf(FDefaultParaFormat^)); | |
| FillChar(FDefaultParaFormat^, SizeOf(FDefaultParaFormat^), 0); | |
| FDefaultParaFormat.cbSize := SizeOf(FDefaultParaFormat^); | |
| FDefaultParaFormat.dwMask := pfm_All; | |
| FDefaultParaFormat.wAlignment := pfa_Left; | |
| FDefaultParaFormat.cTabCount := 1; | |
| FDefaultParaFormat.rgxTabs[0] := lDefaultTab; | |
| end; | |
| destructor TDrawRTFTextHost.Destroy; | |
| begin | |
| FreeMem(FDefaultCharFormat); | |
| FreeMem(FDefaultParaFormat); | |
| inherited; | |
| end; | |
| function TDrawRTFTextHost.OnTxCharFormatChange(const pcf: TCharFormatW): HResult; | |
| var | |
| NewCharFormat: PCharFormatW; | |
| begin | |
| try | |
| GetMem(NewCharFormat, pcf.cbSize); | |
| Move(pcf, NewCharFormat^, pcf.cbSize); | |
| FreeMem(FDefaultCharFormat); | |
| PCharFormatW(FDefaultCharFormat) := NewCharFormat; | |
| Result := S_OK; | |
| except | |
| Result := E_Fail; | |
| end; | |
| end; | |
| function TDrawRTFTextHost.OnTxParaFormatChange(const ppf: TParaFormat): HResult; | |
| var | |
| NewParaFormat: PParaFormat; | |
| begin | |
| try | |
| GetMem(NewParaFormat, ppf.cbSize); | |
| Move(ppf, NewParaFormat^, ppf.cbSize); | |
| FreeMem(FDefaultParaFormat); | |
| PParaFormat(FDefaultParaFormat) := NewParaFormat; | |
| Result := S_OK; | |
| except | |
| Result := E_Fail; | |
| end; | |
| end; | |
| function TDrawRTFTextHost.TxGetBackStyle(out pstyle: TTxtBackStyle): HResult; | |
| begin | |
| if FTransparent then | |
| pstyle := txtBack_Transparent | |
| else | |
| pstyle := txtBack_Opaque; | |
| Result := S_OK; | |
| end; | |
| function TDrawRTFTextHost.TxGetCharFormat(out ppCF: PCharFormatW): HResult; | |
| begin | |
| ppCF := PCharFormatW(FDefaultCharFormat); | |
| Result := S_OK; | |
| end; | |
| function TDrawRTFTextHost.TxGetClientRect(out prc: TRect): HResult; | |
| begin | |
| prc := FRect; | |
| Result := S_OK; | |
| end; | |
| function TDrawRTFTextHost.TxGetParaFormat(out ppPF: PParaFormat): HResult; | |
| begin | |
| ppPF := PParaFormat(FDefaultParaFormat); | |
| Result := S_OK; | |
| end; | |
| function TDrawRTFTextHost.TxGetPropertyBits(dwMask: DWord; out pdwBits: DWord): HResult; | |
| begin | |
| pdwBits := txtBit_DisableDrag or txtBit_Multiline or txtBit_RichText; | |
| if FWordWrap then | |
| pdwBits := pdwBits or txtBit_WordWrap; | |
| pdwBits := pdwBits and dwMask; | |
| Result := S_OK; | |
| end; | |
| function TDrawRTFTextHost.TxNotify(iNotify: DWord; pv: Pointer): HResult; | |
| begin | |
| case iNotify of | |
| en_Update: Result := S_OK; | |
| else Result := inherited TxNotify(iNotify, pv); | |
| end; | |
| end; | |
| end. |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| // Delphi interface unit for the windowless rich-edit control | |
| // http://msdn.microsoft.com/library/en-us/shellcc/platform/commctls/richedit/windowlessricheditcontrols.asp | |
| // Copyright © 2003-2006 Rob Kennedy. Some rights reserved. | |
| // For license information, see http://www.cs.wisc.edu/~rkennedy/license | |
| // This code was written using Delphi 5. It should not require any special | |
| // features missing from previous versions, though, except for the obvious | |
| // COM interface support. It should also work with later Delphi versions. | |
| unit TOM; | |
| interface | |
| uses Windows, ActiveX, RichEdit, IMM; | |
| const | |
| // These GUIDs come from the following newsgroup message. | |
| // [email protected] | |
| // Re: ITextServices (Microsoft Text Object Model) | |
| // comp.os.ms-windows.programmer.controls, comp.os.ms-windows.programmer.ole, comp.os.ms-windows.programmer.win32 | |
| // Frederic Marchal ([email protected]) | |
| // 2003-01-19 07:28:50 PST | |
| // http://groups.google.com/groups?selm=92gl2vcsn6ie92e71228cr2jkpvap9t6g6%404ax.com | |
| SID_ITextHost = '{c5bdd8d0-d26e-11ce-a89e-00aa006cadc5}'; | |
| SID_ITextServices = '{8d33f740-cf58-11ce-a89d-00aa006cadc5}'; | |
| IID_ITextHost: TGUID = SID_ITextHost; | |
| IID_ITextServices: TGUID = SID_ITextServices; | |
| // The following declarations are based on the contents of the TextServ.h | |
| // Windows SDK header file as of 26 March 2003. | |
| type | |
| // These pointer types are missing from Borland's declarations. | |
| PCharFormat = ^TCharFormat; | |
| PCharFormatA = ^TCharFormatA; | |
| PCharFormatW = ^TCharFormatW; | |
| PParaFormat = ^TParaFormat; | |
| TSizeL = TSize; | |
| TRectL = TRect; | |
| // For the en_RequestResize notification message | |
| PReqResize = ^TReqResize; | |
| TReqResize = packed record | |
| nmhdr: TNMHdr; | |
| rc: TRect; | |
| end; | |
| const | |
| txtBit_RichText = 1; | |
| txtBit_Multiline = 2; | |
| txtBit_ReadOnly = 4; | |
| txtBit_ShowAccelerator = 8; | |
| txtBit_UsePassword = $10; | |
| txtBit_HideSelection = $20; | |
| txtBit_SaveSelection = $40; | |
| txtBit_AutoWordSel = $80; | |
| txtBit_Vertical = $100; | |
| txtBit_SelBarChange = $200; | |
| txtBit_WordWrap = $400; | |
| txtBit_AllowBeep = $800; | |
| txtBit_DisableDrag = $1000; | |
| txtBit_ViewInsetChange = $2000; | |
| txtBit_BackStyleChange = $4000; | |
| txtBit_MaxLengthChange = $8000; | |
| txtBit_ScrollBarChange = $10000; | |
| txtBit_CharFormatChange = $20000; | |
| txtBit_ParaFormatChange = $40000; | |
| txtBit_ExtentChange = $80000; | |
| txtBit_ClientRectChange = $100000; | |
| txtBit_UseCurrentBkg = $200000; | |
| txtNS_FitToContent = 1; | |
| txtNS_RoundToLine = 2; | |
| type | |
| {$MINENUMSIZE 4} | |
| TTxtBackStyle = (txtBack_Transparent, txtBack_Opaque); | |
| TTxtView = (txtView_Active, txtView_Inactive); | |
| TTxDrawCallback = function(param: DWord): Bool; stdcall; | |
| ITextServices = interface | |
| [SID_ITextServices] | |
| function TxSendMessage(msg: UInt; wParam: wParam; lParam: lParam; out plresult: lResult): HResult; stdcall; | |
| function TxDraw(dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcBounds, lprcWBounds: TRectL; const lprcUpdate: TRect; pfnContinue: TTxDrawCallback; dwContinue: DWord; lViewID: TTxtView): HResult; stdcall; | |
| function TxGetHScroll(out plMin, plMax, plPos, plPage: LongInt; out pfEnabled: Bool): HResult; stdcall; | |
| function TxGetVScroll(out plMin, plMax, plPos, plPage: LongInt; out pfEnabled: Bool): HResult; stdcall; | |
| function OnTxSetCursor(dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcClient: TRect; x, y: Integer): HResult; stdcall; | |
| function TxQueryHitPoint(dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcClient: TRect; x, y: Integer; out pHitResult: DWord): HResult; stdcall; | |
| function OnTxInPlaceActivate(const prcClient: TRect): HResult; stdcall; | |
| function OnTxInPlaceDeactivate: HResult; stdcall; | |
| function OnTxUIActivate: HResult; stdcall; | |
| function OnTxUIDeactivate: HResult; stdcall; | |
| function TxGetText(out pbstrText: TBStr): HResult; stdcall; | |
| function TxSetText(pszText: PWideChar): HResult; stdcall; | |
| function TxGetCurTargetX(out px: LongInt): HResult; stdcall; | |
| function TxGetBaselinePos(out pBaselinePos: LongInt): HResult; stdcall; | |
| function TxGetNaturalSize(dwAspect: DWord; hdcDraw, hicTargetDev: HDC; ptd: PDVTargetDevice; dwMode: DWord; const psizelExtent: TSizeL; var pwidth, pheight: LongInt): HResult; stdcall; | |
| function TxGetDropTarget(out ppDropTarget: IDropTarget): HResult; stdcall; | |
| function OnTxPropertyBitsChange(dwMask, dwBits: DWord): HResult; stdcall; | |
| function TxGetCachedSize(out pdwWidth, pdwHeight: DWord): HResult; stdcall; | |
| end; | |
| ITextHost = interface | |
| [SID_ITextHost] | |
| function TxGetDC: HDC; stdcall; | |
| function TxReleaseDC(hdc: HDC): Integer; stdcall; | |
| function TxShowScrollBar(fnBar: Integer; fShow: Bool): Bool; stdcall; | |
| function TxEnableScrollBar(fuSBFlags, fuArrowFlags: Integer): Bool; stdcall; | |
| function TxSetScrollRange(fnBar: Integer; nMinPos: LongInt; nMaxPos: Integer; fRedraw: Bool): Bool; stdcall; | |
| function TxSetScrollPos(fnBar, nPos: Integer; fRedraw: Bool): Bool; stdcall; | |
| procedure TxInvalidateRect(const prc: TRect; fMode: Bool); stdcall; | |
| procedure TxViewChange(fUpdate: Bool); stdcall; | |
| function TxCreateCaret(hbmp: hBitmap; xWidth, yHeight: Integer): Bool; stdcall; | |
| function TxShowCaret(fShow: Bool): Bool; stdcall; | |
| function TxSetCaretPos(x, y: Integer): Bool; stdcall; | |
| function TxSetTimer(idTimer, uTimeout: UInt): Bool; stdcall; | |
| procedure TxKillTimer(idTimer: UInt); stdcall; | |
| procedure TxScrollWindowEx(dx, dy: Integer; const lprcScroll, lprcClip: TRect; hrgnUpdate: HRgn; fuScroll: UInt); stdcall; | |
| procedure TxSetCapture(fCapture: Bool); stdcall; | |
| procedure TxSetFocus; stdcall; | |
| procedure TxSetCursor(hcur: hCursor; fText: Bool); stdcall; | |
| function TxScreenToClient(var lppt: TPoint): Bool; stdcall; | |
| function TxClientToScreen(var lppt: TPoint): Bool; stdcall; | |
| function TxActivate(out lpOldState: LongInt): HResult; stdcall; | |
| function TxDeactivate(lNewState: LongInt): HResult; stdcall; | |
| function TxGetClientRect(out prc: TRect): HResult; stdcall; | |
| function TxGetViewInset(out prc: TRect): HResult; stdcall; | |
| function TxGetCharFormat(out ppCF: PCharFormatW): HResult; stdcall; | |
| function TxGetParaFormat(out ppPF: PParaFormat): HResult; stdcall; | |
| function TxGetSysColor(nIndex: Integer): TColorRef; stdcall; | |
| function TxGetBackStyle(out pstyle: TTxtBackStyle): HResult; stdcall; | |
| function TxGetMaxLength(out pLength: DWord): HResult; stdcall; | |
| function TxGetScrollBars(out pdwScrollBar: DWord): HResult; stdcall; | |
| function TxGetPasswordChar(out pch: {Wide}Char): HResult; stdcall; | |
| function TxGetAcceleratorPos(out pcp: LongInt): HResult; stdcall; | |
| function TxGetExtent(out lpExtent: TSizeL): HResult; stdcall; | |
| function OnTxCharFormatChange(const pcf: TCharFormatW): HResult; stdcall; | |
| function OnTxParaFormatChange(const ppf: TParaFormat): HResult; stdcall; | |
| function TxGetPropertyBits(dwMask: DWord; out pdwBits: DWord): HResult; stdcall; | |
| function TxNotify(iNotify: DWord; pv: Pointer): HResult; stdcall; | |
| function TxImmGetContext: hIMC; stdcall; | |
| procedure TxImmReleaseContext(himc: hIMC); stdcall; | |
| function TxGetSelectionBarWidth(out lSelBarWidth: LongInt): HResult; stdcall; | |
| end; | |
| // TTextHostImpl is a helper class for implementors of the ITextHost | |
| // interface in Delphi. It could have been declared as an actual | |
| // implementor of ITextHost itself, but since it has to be wrapped by | |
| // CreateTextHost anyway, I didn't want to have to deal with reference | |
| // counting of a helper class and forwarding calls to IUnknown's methods. | |
| // TTextHostImpl provides default implementations for most of the | |
| // methods. Override them in descendents. TxGetPropertyBits is an | |
| // abstract method since I could not decide on a suitable default return | |
| // value. The layout of this class is important. The virtual-method table | |
| // MUST have the same layout as the ITextHost method table. To use | |
| // TTextHostImpl with a windowless rich-edit control, create an instance | |
| // of a descendent and pass it to CreateTextHost (declared below). | |
| // CreateTextHost takes ownership of the TTextHostImpl object; do not | |
| // free it. | |
| TTextHostImpl = class | |
| public | |
| function TxGetDC: HDC; virtual; stdcall; | |
| function TxReleaseDC(hdc: HDC): Integer; virtual; stdcall; | |
| function TxShowScrollBar(fnBar: Integer; fShow: Bool): Bool; virtual; stdcall; | |
| function TxEnableScrollBar(fuSBFlags, fuArrowFlags: Integer): Bool; virtual; stdcall; | |
| function TxSetScrollRange(fnBar: Integer; nMinPos: LongInt; nMaxPos: Integer; fRedraw: Bool): Bool; virtual; stdcall; | |
| function TxSetScrollPos(fnBar, nPos: Integer; fRedraw: Bool): Bool; virtual; stdcall; | |
| procedure TxInvalidateRect(const prc: TRect; fMode: Bool); virtual; stdcall; | |
| procedure TxViewChange(fUpdate: Bool); virtual; stdcall; | |
| function TxCreateCaret(hbmp: hBitmap; xWidth, yHeight: Integer): Bool; virtual; stdcall; | |
| function TxShowCaret(fShow: Bool): Bool; virtual; stdcall; | |
| function TxSetCaretPos(x, y: Integer): Bool; virtual; stdcall; | |
| function TxSetTimer(idTimer, uTimeout: UInt): Bool; virtual; stdcall; | |
| procedure TxKillTimer(idTimer: UInt); virtual; stdcall; | |
| procedure TxScrollWindowEx(dx, dy: Integer; const lprcScroll, lprcClip: TRect; hrgnUpdate: HRgn; fuScroll: UInt); virtual; stdcall; | |
| procedure TxSetCapture(fCapture: Bool); virtual; stdcall; | |
| procedure TxSetFocus; virtual; stdcall; | |
| procedure TxSetCursor(hcur: hCursor; fText: Bool); virtual; stdcall; | |
| function TxScreenToClient(var lppt: TPoint): Bool; virtual; stdcall; | |
| function TxClientToScreen(var lppt: TPoint): Bool; virtual; stdcall; | |
| function TxActivate(out lpOldState: LongInt): HResult; virtual; stdcall; | |
| function TxDeactivate(lNewState: LongInt): HResult; virtual; stdcall; | |
| function TxGetClientRect(out prc: TRect): HResult; virtual; stdcall; | |
| function TxGetViewInset(out prc: TRect): HResult; virtual; stdcall; | |
| function TxGetCharFormat(out ppCF: PCharFormatW): HResult; virtual; stdcall; | |
| function TxGetParaFormat(out ppPF: PParaFormat): HResult; virtual; stdcall; | |
| function TxGetSysColor(nIndex: Integer): TColorRef; virtual; stdcall; | |
| function TxGetBackStyle(out pstyle: TTxtBackStyle): HResult; virtual; stdcall; | |
| function TxGetMaxLength(out pLength: DWord): HResult; virtual; stdcall; | |
| function TxGetScrollBars(out pdwScrollBar: DWord): HResult; virtual; stdcall; | |
| function TxGetPasswordChar(out pch: {Wide}Char): HResult; virtual; stdcall; | |
| function TxGetAcceleratorPos(out pcp: LongInt): HResult; virtual; stdcall; | |
| function TxGetExtent(out lpExtent: TSizeL): HResult; virtual; stdcall; | |
| function OnTxCharFormatChange(const pcf: TCharFormatW): HResult; virtual; stdcall; | |
| function OnTxParaFormatChange(const ppf: TParaFormat): HResult; virtual; stdcall; | |
| function TxGetPropertyBits(dwMask: DWord; out pdwBits: DWord): HResult; virtual; stdcall; abstract; | |
| function TxNotify(iNotify: DWord; pv: Pointer): HResult; virtual; stdcall; | |
| function TxImmGetContext: hIMC; virtual; stdcall; | |
| procedure TxImmReleaseContext(himc: hIMC); virtual; stdcall; | |
| function TxGetSelectionBarWidth(out lSelBarWidth: LongInt): HResult; virtual; stdcall; | |
| end; | |
| // CreateTextHost wraps a TTextHostImpl instance and returns an ITextHost | |
| // interface reference suitable for passing to CreateTextServices. | |
| // | |
| // Caution: Delphi code must NEVER call any functions using the returned | |
| // interface, except for the methods introduced in IUnknown. The actual | |
| // ITextHost methods use the thiscall calling convention, which Delphi | |
| // doesn't understand. If you need to call those methods, call them via | |
| // the original TTextHostImpl reference instead. | |
| // | |
| // See also: TTextHostImpl | |
| function CreateTextHost(const Impl: TTextHostImpl): ITextHost; | |
| // This is the API function, documented by Microsoft. See MSDN for details. | |
| function CreateTextServices(punkOuter: IUnknown; pITextHost: ITextHost; out ppUnk): HResult; stdcall; | |
| // PatchTextServices takes an ITextServices reference, as returned by | |
| // CreateTextServices, and wraps it within a Delphi-compatible | |
| // ITextServices implementation. | |
| // | |
| // Services | |
| // [in,out] On entry, this parameter is a reference to an ITextServices | |
| // object returned by CreateTextServices. On exit, it is a reference to a | |
| // new ITextServices object suitable for use in Delphi. | |
| // | |
| // This function is necessary because the ITextServices interface is | |
| // written to expect the thiscall calling convention, not the usual | |
| // stdcall. Instead of passing Self as a regular variable on the stack, it | |
| // is passed in the ECX register. PatchTextServices creates a wrapper | |
| // object that fixes the stack layout for each function before forwarding | |
| // the call to the original object. | |
| // | |
| // See also: CreateTextServices | |
| procedure PatchTextServices(var Services: ITextServices); | |
| implementation | |
| uses SysUtils; | |
| function CreateTextServices; external 'riched20.dll'; | |
| type | |
| TQueryInterface = function(const This: IUnknown; const riid: TGUID; out ppvObj): HResult; stdcall; | |
| // Many of the following routines are declared without any parameters or | |
| // return types. This is because they must use the stdcall calling | |
| // convention, but the compiler automatically adds prologue and epilogue | |
| // code for all stdcall functions, even if it isn't strictly necessary. | |
| // This is OK, though, since these functions are all implemented in | |
| // assembler and they are never called by any Delphi code. They're always | |
| // called via an interface reference, usually by the operating system. | |
| type | |
| PITextServicesMT = ^TITextServicesMT; | |
| TITextServicesMT = packed record | |
| // IUnknown | |
| QueryInterface: TQueryInterface; | |
| _AddRef, | |
| _Release: TProcedure; | |
| // ITextServices | |
| TxSendMessage, | |
| TxDraw, | |
| TxGetHScroll, | |
| TxGetVScroll, | |
| OnTxSetCursor, | |
| TxQueryHitPoint, | |
| OnTxInPlaceActivate, | |
| OnTxInPlaceDeactivate, | |
| OnTxUIActivate, | |
| OnTxUIDeactivate, | |
| TxGetText, | |
| TxSetText, | |
| TxGetCurTargetX, | |
| TxGetBaselinePos, | |
| TxGetNaturalSize, | |
| TxGetDropTarget, | |
| OnTxPropertyBitsChange, | |
| TxGetCachedSize: TProcedure; | |
| end; | |
| PITextServices = ^TITextServices; | |
| TITextServices = packed record | |
| MethodTable: PITextServicesMT; | |
| Impl: ITextServices; | |
| end; | |
| function TextServices_QueryInterface(const This: IUnknown; const riid: TGUID; out ppvObj): HResult; stdcall; | |
| begin | |
| Result := PITextServices(This).Impl.QueryInterface(riid, ppvObj); | |
| end; | |
| procedure TextServices_AddRef; // (const This: IUnknown): ULong; stdcall; | |
| {begin | |
| Result := PITextServices(This).Impl._AddRef;} | |
| asm | |
| mov eax, [esp + 4] | |
| mov eax, [eax].TITextServices.Impl | |
| mov [esp + 4], eax | |
| mov eax, [eax] | |
| jmp dword ptr [eax].TITextServicesMT._AddRef | |
| end; | |
| procedure ReleaseTextServices(const Services: PITextServices); | |
| // This procedure is not in assembler because Dispose requires compiler | |
| // magic in order to include TypeInfo for a PITextServices pointer. | |
| begin | |
| Pointer(Services.Impl) := nil; | |
| Dispose(Services); | |
| end; | |
| procedure TextServices_Release; // (const This: IUnknown): ULong; stdcall; | |
| {begin | |
| Result := PITextServices(This).Impl._Release; | |
| if Result = 0 then ReleaseTextServices(PTextServices(This));} | |
| asm | |
| mov eax, [esp + 4] | |
| mov eax, [eax].TITextServices.Impl | |
| push eax | |
| mov eax, [eax] | |
| call dword ptr [eax].TITextServicesMT._Release | |
| test eax, eax | |
| jnz @@exit | |
| mov eax, [esp + 4] | |
| call ReleaseTextServices | |
| xor eax, eax | |
| @@exit: | |
| ret 4 | |
| end; | |
| // These stubs get called as stdcall methods. They translate the stack into | |
| // a thiscall method. First, there is a breakpoint, which can be set or | |
| // ignored when a method is patched. Next, we pop the return address into | |
| // EDX. Then we pop the Self parameter that Delphi puts at the top of the | |
| // stack. It's actually a PITextServices value. The real ITextServices | |
| // implementor is expecting to find its instance reference in ECX when we | |
| // call it, and that got stored in the Inst field of the TITextServices | |
| // record by the PatchTextServices function. After we set ECX, we push the | |
| // return address back onto the stack (note the PITextServices reference is | |
| // *not* pushed back on). ECX points to the first entry of the | |
| // implementor's VMT, so we add an offset to that pointer and jump to the | |
| // address stored there. | |
| procedure TextServices_TxSendMessage; // (msg: UInt; wParam: wParam; lParam: lParam; out plresult: lResult): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxSendMessage | |
| end; | |
| procedure TextServices_TxDraw; // (dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcBounds, lprcWBounds: TRectL; const lprcUpdate: TRect; pfnContinue: TTxDrawCallback; dwContinue: DWord; lViewID: TTxtView): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxDraw | |
| end; | |
| procedure TextServices_TxGetHScroll; // (out plMin, plMax, plPos, plPage: LongInt; out pfEnabled: Bool): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetHScroll | |
| end; | |
| procedure TextServices_TxGetVScroll; // (out plMin, plMax, plPos, plPage: LongInt; out pfEnabled: Bool): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetVScroll | |
| end; | |
| procedure TextServices_OnTxSetCursor; // (dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcClient: TRect; x, y: Integer): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxSetCursor | |
| end; | |
| procedure TextServices_TxQueryHitPoint; // (dwDrawAspect: DWord; lindex: LongInt; pvAspect: Pointer; ptd: PDVTargetDevice; hdcDraw, hicTargetDev: HDC; const lprcClient: TRect; x, y: Integer; out pHitResult: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxQueryHitPoint | |
| end; | |
| procedure TextServices_OnTxInPlaceActivate; // (const prcClient: TRect): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxInPlaceActivate | |
| end; | |
| procedure TextServices_OnTxInPlaceDeactivate; // : HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxInPlaceDeactivate | |
| end; | |
| procedure TextServices_OnTxUIActivate; // : HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxUIActivate | |
| end; | |
| procedure TextServices_OnTxUIDeactivate; // : HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxUIDeactivate | |
| end; | |
| procedure TextServices_TxGetText; // (out pbstrText: TBStr): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetText | |
| end; | |
| procedure TextServices_TxSetText; // (pszText: PWideChar): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxSetText | |
| end; | |
| procedure TextServices_TxGetCurTargetX; // (out px: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetCurTargetX | |
| end; | |
| procedure TextServices_TxGetBaselinePos; // (out pBaselinePos: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetBaselinePos | |
| end; | |
| procedure TextServices_TxGetNaturalSize; // (dwAspect: DWord; hdcDraw, hicTargetDev: HDC; ptd: PDVTargetDevice; dwMode: DWord; const psizelExtent: TSizeL; var pwidth, pheight: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetNaturalSize | |
| end; | |
| procedure TextServices_TxGetDropTarget; // (out ppDropTarget: IDropTarget): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetDropTarget | |
| end; | |
| procedure TextServices_OnTxPropertyBitsChange; // (dwMask, dwBits: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.OnTxPropertyBitsChange | |
| end; | |
| procedure TextServices_TxGetCachedSize; // (out pdwWidth, pdwHeight: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| pop eax | |
| mov ecx, [eax].TITextServices.Impl | |
| push edx // return address | |
| mov eax, [ecx] | |
| jmp dword ptr [eax].TITextServicesMT.TxGetCachedSize | |
| end; | |
| var | |
| TextServicesMethodTable: TITextServicesMT = ( | |
| // IUnknown | |
| QueryInterface: TextServices_QueryInterface; | |
| _AddRef: TextServices_AddRef; | |
| _Release: TextServices_Release; | |
| // ITextServices | |
| TxSendMessage: TextServices_TxSendMessage; | |
| TxDraw: TextServices_TxDraw; | |
| TxGetHScroll: TextServices_TxGetHScroll; | |
| TxGetVScroll: TextServices_TxGetVScroll; | |
| OnTxSetCursor: TextServices_OnTxSetCursor; | |
| TxQueryHitPoint: TextServices_TxQueryHitPoint; | |
| OnTxInPlaceActivate: TextServices_OnTxInPlaceActivate; | |
| OnTxInPlaceDeactivate: TextServices_OnTxInPlaceDeactivate; | |
| OnTxUIActivate: TextServices_OnTxUIActivate; | |
| OnTxUIDeactivate: TextServices_OnTxUIDeactivate; | |
| TxGetText: TextServices_TxGetText; | |
| TxSetText: TextServices_TxSetText; | |
| TxGetCurTargetX: TextServices_TxGetCurTargetX; | |
| TxGetBaselinePos: TextServices_TxGetBaselinePos; | |
| TxGetNaturalSize: TextServices_TxGetNaturalSize; | |
| TxGetDropTarget: TextServices_TxGetDropTarget; | |
| OnTxPropertyBitsChange: TextServices_OnTxPropertyBitsChange; | |
| TxGetCachedSize: TextServices_TxGetCachedSize | |
| ); | |
| type | |
| PITextHostMT = ^TITextHostMT; | |
| TITextHostMT = packed record | |
| // IUnknown | |
| QueryInterface: TQueryInterface; | |
| _AddRef, | |
| _Release: TProcedure; | |
| // ITextHost | |
| TxGetDC, | |
| TxReleaseDC, | |
| TxShowScrollBar, | |
| TxEnableScrollBar, | |
| TxSetScrollRange, | |
| TxSetScrollPos, | |
| TxInvalidateRect, | |
| TxViewChange, | |
| TxCreateCaret, | |
| TxShowCaret, | |
| TxSetCaretPos, | |
| TxSetTimer, | |
| TxKillTimer, | |
| TxScrollWindowEx, | |
| TxSetCapture, | |
| TxSetFocus, | |
| TxSetCursor, | |
| TxScreenToClient, | |
| TxClientToScreen, | |
| TxActivate, | |
| TxDeactivate, | |
| TxGetClientRect, | |
| TxGetViewInset, | |
| TxGetCharFormat, | |
| TxGetParaFormat, | |
| TxGetSysColor, | |
| TxGetBackStyle, | |
| TxGetMaxLength, | |
| TxGetScrollBars, | |
| TxGetPasswordChar, | |
| TxGetAcceleratorPos, | |
| TxGetExtent, | |
| OnTxCharFormatChange, | |
| OnTxParaFormatChange, | |
| TxGetPropertyBits, | |
| TxNotify, | |
| TxImmGetContext, | |
| TxImmReleaseContext, | |
| TxGetSelectionBarWidth: TProcedure; | |
| end; | |
| PITextHost = ^TITextHost; | |
| TITextHost = record | |
| MethodTable: PITextHostMT; | |
| RefCount: Cardinal; | |
| Impl: TTextHostImpl; | |
| end; | |
| function TextHost_QueryInterface(const This: IUnknown; const riid: TGUID; out ppvObj): HResult; stdcall; | |
| begin | |
| if IsEqualGUID(riid, IUnknown) or IsEqualGUID(riid, ITextHost) then begin | |
| Pointer(ppvObj) := Pointer(This); | |
| IUnknown(ppvObj)._AddRef; | |
| Result := S_OK; | |
| end else begin | |
| Pointer(ppvObj) := nil; | |
| Result := E_NoInterface; | |
| end; | |
| end; | |
| procedure TextHost_AddRef; // (const This: IUnknown): ULong; stdcall; | |
| {begin | |
| Result := InterlockedIncrement(PITextHost(This).RefCount);} | |
| asm | |
| mov eax, [esp + 4] | |
| lea eax, [eax].TITextHost.RefCount | |
| push eax | |
| call InterlockedIncrement | |
| ret 4 // return from stdcall function | |
| end; | |
| procedure ReleaseTextHost(const Host: PITextHost); | |
| begin | |
| Host.Impl.Free; | |
| Dispose(Host); | |
| end; | |
| procedure TextHost_Release; // (const This: IUnknown): ULong; stdcall; | |
| {begin | |
| Result := InterlockedDecrement(PITextHost(This).RefCount); | |
| if Result = 0 then ReleaseTextHost(PITextHost(This));} | |
| asm | |
| mov eax, [esp + 4] | |
| lea eax, [eax].TITextHost.RefCount | |
| push eax | |
| call InterlockedDecrement | |
| test eax, eax | |
| jnz @@exit | |
| mov eax, [esp + 4] | |
| call ReleaseTextHost | |
| xor eax, eax | |
| @@exit: | |
| ret 4 // return from stdcall function | |
| end; | |
| // When these stubs get called, it is as thiscall methods. We translate it | |
| // to a stdcall method and then jump to the Delphi object method that's | |
| // implementing the interface. ECX refers to the PITextHost value that | |
| // CreateTextHost returned as an ITextHost reference. Besides a pointer to | |
| // a VMT of these method stubs, that record also contains a reference to | |
| // the TTextHostImpl instance, eight bytes into the record. That reference | |
| // gets stored in EAX and then pushed onto the stack underneath the return | |
| // address. Then we fetch the address of the method being wrapped from the | |
| // TTextHostImpl's VMT and jump to that method. | |
| procedure TextHost_TxGetDC; // : HDC; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetDC] | |
| end; | |
| procedure TextHost_TxReleaseDC; // (hdc: HDC): Integer; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxReleaseDC] | |
| end; | |
| procedure TextHost_TxShowScrollBar; // (fnBar: Integer; fShow: Bool): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxShowScrollBar] | |
| end; | |
| procedure TextHost_TxEnableScrollBar; // (fuSBFlags, fuArrowFlags: Integer): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxEnableScrollBar] | |
| end; | |
| procedure TextHost_TxSetScrollRange; // (fnBar: Integer; nMinPos: LongInt; nMaxPos: Integer; fRedraw: Bool): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetScrollRange] | |
| end; | |
| procedure TextHost_TxSetScrollPos; // (fnBar, nPos: Integer; fRedraw: Bool): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetScrollPos] | |
| end; | |
| procedure TextHost_TxInvalidateRect; // (const prc: TRect; fMode: Bool); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxInvalidateRect] | |
| end; | |
| procedure TextHost_TxViewChange; // (fUpdate: Bool); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxViewChange] | |
| end; | |
| procedure TextHost_TxCreateCaret; // (hbmp: hBitmap; xWidth, yHeight: Integer): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxCreateCaret] | |
| end; | |
| procedure TextHost_TxShowCaret; // (fShow: Bool): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxShowCaret] | |
| end; | |
| procedure TextHost_TxSetCaretPos; // (x, y: Integer): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetCaretPos] | |
| end; | |
| procedure TextHost_TxSetTimer; // (idTimer, uTimeout: UInt): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetTimer] | |
| end; | |
| procedure TextHost_TxKillTimer; // (idTimer: UInt); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxKillTimer] | |
| end; | |
| procedure TextHost_TxScrollWindowEx; // (dx, dy: Integer; const lprcScroll, lprcClip: TRect; hrgnUpdate: HRgn; fuScroll: UInt); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxScrollWindowEx] | |
| end; | |
| procedure TextHost_TxSetCapture; // (fCapture: Bool); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetCapture] | |
| end; | |
| procedure TextHost_TxSetFocus; // ; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetFocus] | |
| end; | |
| procedure TextHost_TxSetCursor; // (hcur: hCursor; fText: Bool); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxSetCursor] | |
| end; | |
| procedure TextHost_TxScreenToClient; // (var lppt: TPoint): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxScreenToClient] | |
| end; | |
| procedure TextHost_TxClientToScreen; // (var lppt: TPoint): Bool; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxClientToScreen] | |
| end; | |
| procedure TextHost_TxActivate; // (out lpOldState: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxActivate] | |
| end; | |
| procedure TextHost_TxDeactivate; // (lNewState: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxDeactivate] | |
| end; | |
| procedure TextHost_TxGetClientRect; // (out prc: TRect): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetClientRect] | |
| end; | |
| procedure TextHost_TxGetViewInset; // (out prc: TRect): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetViewInset] | |
| end; | |
| procedure TextHost_TxGetCharFormat; // (out ppCF: PCharFormatW): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetCharFormat] | |
| end; | |
| procedure TextHost_TxGetParaFormat; // (out ppPF: PParaFormat): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetParaFormat] | |
| end; | |
| procedure TextHost_TxGetSysColor; // (nIndex: Integer): TColorRef; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetSysColor] | |
| end; | |
| procedure TextHost_TxGetBackStyle; // (out pstyle: TTxtBackStyle): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetBackStyle] | |
| end; | |
| procedure TextHost_TxGetMaxLength; // (out pLength: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetMaxLength] | |
| end; | |
| procedure TextHost_TxGetScrollBars; // (out pdwScrollBar: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetScrollBars] | |
| end; | |
| procedure TextHost_TxGetPasswordChar; // (out pch: {Wide}Char): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetPasswordChar] | |
| end; | |
| procedure TextHost_TxGetAcceleratorPos; // (out pcp: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetAcceleratorPos] | |
| end; | |
| procedure TextHost_TxGetExtent; // (out lpExtent: TSizeL): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetExtent] | |
| end; | |
| procedure TextHost_OnTxCharFormatChange; // (const pcf: TCharFormatW): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.OnTxCharFormatChange] | |
| end; | |
| procedure TextHost_OnTxParaFormatChange; // (const ppf: TParaFormat): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.OnTxParaFormatChange] | |
| end; | |
| procedure TextHost_TxGetPropertyBits; // (dwMask: DWord; out pdwBits: DWord): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetPropertyBits] | |
| end; | |
| procedure TextHost_TxNotify; // (iNotify: DWord; pv: Pointer): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxNotify] | |
| end; | |
| procedure TextHost_TxImmGetContext; // : hIMC; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxImmGetContext] | |
| end; | |
| procedure TextHost_TxImmReleaseContext; // (himc: hIMC); stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxImmReleaseContext] | |
| end; | |
| procedure TextHost_TxGetSelectionBarWidth; // (out lSelBarWidth: LongInt): HResult; stdcall; | |
| asm | |
| pop edx // return address | |
| mov eax, [ecx].TITextHost.Impl | |
| push eax | |
| push edx // return address | |
| mov eax, [eax] | |
| jmp dword ptr [eax + vmtoffset TTextHostImpl.TxGetSelectionBarWidth] | |
| end; | |
| var | |
| TextHostMethodTable: TITextHostMT = ( | |
| // IUnknown | |
| QueryInterface: TextHost_QueryInterface; | |
| _AddRef: TextHost_AddRef; | |
| _Release: TextHost_Release; | |
| // ITextHost | |
| TxGetDC: TextHost_TxGetDC; | |
| TxReleaseDC: TextHost_TxReleaseDC; | |
| TxShowScrollBar: TextHost_TxShowScrollBar; | |
| TxEnableScrollBar: TextHost_TxEnableScrollBar; | |
| TxSetScrollRange: TextHost_TxSetScrollRange; | |
| TxSetScrollPos: TextHost_TxSetScrollPos; | |
| TxInvalidateRect: TextHost_TxInvalidateRect; | |
| TxViewChange: TextHost_TxViewChange; | |
| TxCreateCaret: TextHost_TxCreateCaret; | |
| TxShowCaret: TextHost_TxShowCaret; | |
| TxSetCaretPos: TextHost_TxSetCaretPos; | |
| TxSetTimer: TextHost_TxSetTimer; | |
| TxKillTimer: TextHost_TxKillTimer; | |
| TxScrollWindowEx: TextHost_TxScrollWindowEx; | |
| TxSetCapture: TextHost_TxSetCapture; | |
| TxSetFocus: TextHost_TxSetFocus; | |
| TxSetCursor: TextHost_TxSetCursor; | |
| TxScreenToClient: TextHost_TxScreenToClient; | |
| TxClientToScreen: TextHost_TxClientToScreen; | |
| TxActivate: TextHost_TxActivate; | |
| TxDeactivate: TextHost_TxDeactivate; | |
| TxGetClientRect: TextHost_TxGetClientRect; | |
| TxGetViewInset: TextHost_TxGetViewInset; | |
| TxGetCharFormat: TextHost_TxGetCharFormat; | |
| TxGetParaFormat: TextHost_TxGetParaFormat; | |
| TxGetSysColor: TextHost_TxGetSysColor; | |
| TxGetBackStyle: TextHost_TxGetBackStyle; | |
| TxGetMaxLength: TextHost_TxGetMaxLength; | |
| TxGetScrollBars: TextHost_TxGetScrollBars; | |
| TxGetPasswordChar: TextHost_TxGetPasswordChar; | |
| TxGetAcceleratorPos: TextHost_TxGetAcceleratorPos; | |
| TxGetExtent: TextHost_TxGetExtent; | |
| OnTxCharFormatChange: TextHost_OnTxCharFormatChange; | |
| OnTxParaFormatChange: TextHost_OnTxParaFormatChange; | |
| TxGetPropertyBits: TextHost_TxGetPropertyBits; | |
| TxNotify: TextHost_TxNotify; | |
| TxImmGetContext: TextHost_TxImmGetContext; | |
| TxImmReleaseContext: TextHost_TxImmReleaseContext; | |
| TxGetSelectionBarWidth: TextHost_TxGetSelectionBarWidth; | |
| ); | |
| procedure PatchTextServices(var Services: ITextServices); | |
| var | |
| NewServices: PITextServices; | |
| begin | |
| New(NewServices); | |
| NewServices.MethodTable := @TextServicesMethodTable; | |
| Pointer(NewServices.Impl) := Pointer(Services); | |
| Pointer(Services) := NewServices; | |
| end; | |
| function CreateTextHost(const Impl: TTextHostImpl): ITextHost; | |
| var | |
| Obj: PITextHost; | |
| begin | |
| New(Obj); | |
| Obj.MethodTable := @TextHostMethodTable; | |
| Obj.RefCount := 0; | |
| Obj.Impl := Impl; | |
| Result := ITextHost(Obj); | |
| end; | |
| { TTextHostImpl } | |
| // The following is a generic implementation of the ITextHost interface. | |
| // Many of the methods return E_Fail, but that's actually OK. The OS does | |
| // not expect the text-services object to be fully functional. | |
| function TTextHostImpl.OnTxCharFormatChange(const pcf: TCharFormatW): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.OnTxParaFormatChange(const ppf: TParaFormat): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.TxActivate(out lpOldState: Integer): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.TxClientToScreen(var lppt: TPoint): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxCreateCaret(hbmp: hBitmap; xWidth, yHeight: Integer): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxDeactivate(lNewState: Integer): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.TxEnableScrollBar(fuSBFlags, fuArrowFlags: Integer): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxGetAcceleratorPos(out pcp: Integer): HResult; | |
| begin | |
| pcp := -1; | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxGetBackStyle(out pstyle: TTxtBackStyle): HResult; | |
| begin | |
| pstyle := txtBack_Transparent; | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxGetCharFormat(out ppCF: PCharFormatW): HResult; | |
| begin | |
| Result := E_NotImpl; | |
| end; | |
| function TTextHostImpl.TxGetClientRect(out prc: TRect): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.TxGetDC: HDC; | |
| begin | |
| Result := 0; | |
| end; | |
| function TTextHostImpl.TxGetExtent(out lpExtent: TSizeL): HResult; | |
| begin | |
| Result := E_Fail; | |
| end; | |
| function TTextHostImpl.TxGetMaxLength(out pLength: DWord): HResult; | |
| begin | |
| pLength := Infinite; | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxGetParaFormat(out ppPF: PParaFormat): HResult; | |
| begin | |
| Result := E_NotImpl; | |
| end; | |
| function TTextHostImpl.TxGetPasswordChar(out pch: Char): HResult; | |
| begin | |
| Result := S_False; | |
| end; | |
| function TTextHostImpl.TxGetScrollBars(out pdwScrollBar: DWord): HResult; | |
| begin | |
| pdwScrollBar := 0; | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxGetSelectionBarWidth(out lSelBarWidth: Integer): HResult; | |
| begin | |
| lSelBarWidth := 0; | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxGetSysColor(nIndex: Integer): TColorRef; | |
| begin | |
| Result := GetSysColor(nIndex); | |
| end; | |
| function TTextHostImpl.TxGetViewInset(out prc: TRect): HResult; | |
| begin | |
| SetRect(prc, 0, 0, 0, 0); | |
| Result := S_OK; | |
| end; | |
| function TTextHostImpl.TxImmGetContext: hIMC; | |
| begin | |
| Result := 0; | |
| end; | |
| procedure TTextHostImpl.TxImmReleaseContext(himc: hIMC); | |
| begin | |
| end; | |
| procedure TTextHostImpl.TxInvalidateRect(const prc: TRect; fMode: Bool); | |
| begin | |
| end; | |
| procedure TTextHostImpl.TxKillTimer(idTimer: UInt); | |
| begin | |
| end; | |
| function TTextHostImpl.TxNotify(iNotify: DWord; pv: Pointer): HResult; | |
| begin | |
| Result := S_False; | |
| end; | |
| function TTextHostImpl.TxReleaseDC(hdc: HDC): Integer; | |
| begin | |
| Result := 0; | |
| end; | |
| function TTextHostImpl.TxScreenToClient(var lppt: TPoint): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| procedure TTextHostImpl.TxScrollWindowEx(dx, dy: Integer; const lprcScroll, lprcClip: TRect; hrgnUpdate: HRgn; fuScroll: UInt); | |
| begin | |
| end; | |
| procedure TTextHostImpl.TxSetCapture(fCapture: Bool); | |
| begin | |
| end; | |
| function TTextHostImpl.TxSetCaretPos(x, y: Integer): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| procedure TTextHostImpl.TxSetCursor(hcur: hCursor; fText: Bool); | |
| begin | |
| end; | |
| procedure TTextHostImpl.TxSetFocus; | |
| begin | |
| end; | |
| function TTextHostImpl.TxSetScrollPos(fnBar, nPos: Integer; fRedraw: Bool): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxSetScrollRange(fnBar, nMinPos, nMaxPos: Integer; fRedraw: Bool): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxSetTimer(idTimer, uTimeout: UInt): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxShowCaret(fShow: Bool): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| function TTextHostImpl.TxShowScrollBar(fnBar: Integer; fShow: Bool): Bool; | |
| begin | |
| Result := False; | |
| end; | |
| procedure TTextHostImpl.TxViewChange(fUpdate: Bool); | |
| begin | |
| end; | |
| end. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment