////////////////////////////////////////////////////////////////////////////////
// TSpellChecker facilitates on the fly spellchecking using the Windows
// spellchecking API for TRichEdits that have a popup menu.
//
// Create a TSpellChecker object with a TCustomRichEdit component. Spell
// checking on or off is determined by the property SpellChecking of the
// TRichEdit, and whether or not it's ReadOnly.
//
// Create with AUseRichEditSpellCheck True uses the SpellChecking built into
// TRichEdit. AUseRichEditSpellCheck False means that TSpellChecker builds out
// it's own menus. Each has advantages and disadvantages, all centered around
// the "ignore" functionality.
////////////////////////////////////////////////////////////////////////////////

unit SpellCheck.SpellChecker;

interface

uses
  System.Classes,
  Vcl.Menus,
  Vcl.Controls,
  Vcl.ComCtrls,
  Winapi.Windows,
  MsSpellCheckLib_TLB;

type
  TSpellingError = class(TObject)
    // This is sort of an "interface helper" class for ISpellingError.
    // You don't create it, just use the class functions
  private
    FRichEdit: TCustomRichEdit;
    FSpellingError: ISpellingError;
    FMisspelledWord: string;
    FDisplacement: NativeInt;
  protected
    function GetMisspelledWord: string; overload;
    function GetStartIndex: LongWord; overload;
    function GetLength: LongWord; overload;
    function GetCorrectiveAction: TCorrectiveAction; overload;
  public
    constructor Create(ARichEdit: TCustomRichEdit;
      ASpellingError: ISpellingError; ADisplacement: NativeInt = 0);
    property RichEdit: TCustomRichEdit read FRichEdit;
    property SpellingError: ISpellingError read FSpellingError;
    property Displacement: NativeInt read FDisplacement;
    // This is a correction on StartIndex due to replaced words!
    property MisspelledWord: string read GetMisspelledWord;
    property StartIndex: LongWord read GetStartIndex;
    property Length: LongWord read GetLength;
    property CorrectiveAction: TCorrectiveAction read GetCorrectiveAction;
  public
    class function GetMisspelledWord(ASpellingError: ISpellingError;
      ARichEdit: TCustomRichEdit; ADisplacement: NativeInt = 0)
      : string; overload;
    class function GetStartIndex(ASpellingError: ISpellingError;
      ADisplacement: NativeInt = 0): LongWord; overload;
    class function GetLength(ASpellingError: ISpellingError): LongWord;
      overload;
    class function GetCorrectiveAction(ASpellingError: ISpellingError)
      : TCorrectiveAction; overload;
  end;

  TSpellChecker = class(TObject)
  private
    FRichEdit: TCustomRichEdit;
    FSpellChecker: ISpellChecker;
    FOrigContextPopup: TContextPopupEvent;
    FPopupMenu: TPopupMenu;
    FOwnedPopupMenu: TPopupMenu;
    FSpellMenuItem, FSpellMenuSeperator: TMenuItem;
    FUseRichEditSpellCheck: Boolean;
    function GetSpellChecking: Boolean;
  protected
    procedure SpellWordMenuItemClick(Sender: TObject);
    procedure SpellAddMenuItemClick(Sender: TObject);
    procedure SpellDeleteMenuItemClick(Sender: TObject);
    procedure SpellIgnoreMenuItemClick(Sender: TObject);
    procedure ContextPopup(ASender: TObject; AMousePos: TPoint;
      var AHandled: Boolean);
  public
    constructor Create(ARichEdit: TCustomRichEdit;
      ALanguageTag: UnicodeString = 'en-US'); overload;
    constructor Create(ARichEdit: TCustomRichEdit;
      AUseRichEditSpellCheck: Boolean); overload;
    constructor Create(ARichEdit: TCustomRichEdit; ALanguageTag: UnicodeString;
      AUseRichEditSpellCheck: Boolean); overload;
    destructor Destroy; override;
    property RichEdit: TCustomRichEdit read FRichEdit;
    property SpellChecking: Boolean read GetSpellChecking;
    function CheckSpelling(AText: string; AComprehensive: Boolean)
      : IEnumSpellingError;
    function NextError(AEnumSpellingError: IEnumSpellingError): ISpellingError;
    function Execute(AComprehensive: Boolean): TModalResult;
  public
    // methods to determine the word under the mouse/at the index
    class function FindIndex(ARichEdit: TCustomRichEdit; AMousePos: TPoint)
      : NativeInt;
    class function FindStartIndex(ARichEdit: TCustomRichEdit; AIndex: NativeInt)
      : NativeInt; overload;
    class function FindStartIndex(ARichEdit: TCustomRichEdit; AMousePos: TPoint)
      : NativeInt; overload;
    class function FindEndIndex(ARichEdit: TCustomRichEdit; AIndex: NativeInt)
      : NativeInt; overload;
    class function FindTextRange(ARichEdit: TCustomRichEdit;
      AStartPos, AEndPos: NativeInt): string; overload;
    class function FindWord(ARichEdit: TCustomRichEdit; AStartIndex: NativeInt)
      : string; overload;
    function FindStartIndex(AIndex: NativeInt): NativeInt; overload;
    function FindStartIndex(AMousePos: TPoint): NativeInt; overload;
    function FindEndIndex(AIndex: NativeInt): NativeInt; overload;
    function FindWord(AIndex: NativeInt): string; overload;
    function FindWord(AMousePos: TPoint): string; overload;
    function FindTextRange(AStartPos, AEndPos: NativeInt): string; overload;
  public
    // methods to manipulate the spell checking
    procedure Replace(AStartIndex, ALength: Integer; const AWord: string);
    procedure Add(const AWord: string);
    procedure Ignore(const AWord: string);
    procedure Suggest(const AWord: string; ASuggestions: TStrings);
  end;

implementation

uses
  Vcl.ExtActns,
  System.SysUtils,
  System.Actions,
  System.Types,
  Winapi.Messages,
  Winapi.RichEdit,
  Winapi.ActiveX,
  SpellCheck.FSpell;

type
  TSpellCheckAction = class(TRichEditSpellCheck)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

  TSpellMenuItem = class(Vcl.Menus.TMenuItem)
  private
    FMisspelledWord: string;
  protected
    constructor Create; reintroduce; overload;
  public
    constructor Create(AOwner: TComponent); overload; override;
    property MisspelledWord: string read FMisspelledWord;
  end;

  TSpellWordMenuItem = class(TSpellMenuItem)
  private
    FCorrectWord: string;
    FStartIndex: LongWord;
    FLength: LongWord;
  protected
    constructor Create(const AMisspelledWord, ACorrectWord: string;
      AStartIndex: NativeInt; ASpellingError: ISpellingError;
      AOnClick: TNotifyEvent = nil); reintroduce;
  public
    property CorrectWord: string read FCorrectWord;
    property StartIndex: ULONG read FStartIndex;
    property Length: ULONG read FLength;
  end;

  TSpellAddIgnoreMenuItem = class(TSpellMenuItem)
  protected
    constructor Create(const AMisspelledWord, ACaption: string;
      AOnClick: TNotifyEvent = nil); reintroduce;
  end;

constructor TSpellChecker.Create(ARichEdit: TCustomRichEdit;
  ALanguageTag: UnicodeString = 'en-US');
begin
  Create(ARichEdit, ALanguageTag, False);
end;

constructor TSpellChecker.Create(ARichEdit: TCustomRichEdit;
  AUseRichEditSpellCheck: Boolean);
begin
  Create(ARichEdit, 'en-US', AUseRichEditSpellCheck);
end;

constructor TSpellChecker.Create(ARichEdit: TCustomRichEdit;
  ALanguageTag: UnicodeString; AUseRichEditSpellCheck: Boolean);
var
  AFactory: ISpellCheckerFactory;
  ASpellCheckAction: TSpellCheckAction;
begin
  if not Assigned(ARichEdit) then
      raise Exception.Create('ARichEdit not assigned');
  inherited Create;
  FRichEdit := ARichEdit;
  AFactory := CoSpellCheckerFactory.Create;
  if not Assigned(AFactory) then
      raise Exception.Create('AFactory not assigned');
  CheckOSError(AFactory.CreateSpellChecker(PChar(ALanguageTag), FSpellChecker));

  FPopupMenu := TRichEdit(FRichEdit).PopupMenu;
  if not Assigned(FPopupMenu) then
  begin
    FOwnedPopupMenu := TPopupMenu.Create(nil);
    FPopupMenu := FOwnedPopupMenu;
    TRichEdit(FRichEdit).PopupMenu := FPopupMenu;
    FSpellMenuItem := FPopupMenu.Items;
  end else begin
    FSpellMenuItem := TMenuItem.Create(nil);
    FSpellMenuItem.Visible := False;
    FPopupMenu.Items.Insert(0, FSpellMenuItem);
    FSpellMenuSeperator := TMenuItem.Create(nil);
    FSpellMenuSeperator.Caption := '-';
    FPopupMenu.Items.Insert(1, FSpellMenuSeperator);
  end;

  FUseRichEditSpellCheck := AUseRichEditSpellCheck;
  if FUseRichEditSpellCheck then
  begin
    ASpellCheckAction := TSpellCheckAction.Create(nil);
    ASpellCheckAction.Caption := 'Spelling...';
    FSpellMenuItem.Action := ASpellCheckAction;
  end else begin
    FSpellMenuItem.Caption := 'Spelling...';
  end;

  FOrigContextPopup := TRichEdit(FRichEdit).OnContextPopup;
  TRichEdit(FRichEdit).OnContextPopup := ContextPopup;
end;

destructor TSpellChecker.Destroy;
begin
  TRichEdit(FRichEdit).OnContextPopup := FOrigContextPopup;

  FSpellMenuItem.Action.Free;
  FSpellMenuItem.Action := nil;
  FreeAndNil(FSpellMenuSeperator);
  if not Assigned(FOwnedPopupMenu) then
  begin
    FreeAndNil(FSpellMenuItem);
  end else begin
    FSpellMenuItem := nil;
    FreeAndNil(FOwnedPopupMenu);
    TRichEdit(FRichEdit).PopupMenu := nil;
  end;
  FSpellChecker := nil;
  inherited;
end;

procedure TSpellChecker.ContextPopup(ASender: TObject; AMousePos: TPoint;
  var AHandled: Boolean);

  procedure BuildSpellMenu(AMisspelledWord: string; AStartIndex: NativeInt;
    ASpellingError: ISpellingError);
  var
    S: string;
    ASuggestions: TStringList;
    AMenuItem: TMenuItem;
  begin
    FSpellMenuItem.Clear; // This frees the menuitems underneath

    // Ensure the popup is what we expect it to be
    if TRichEdit(FRichEdit).PopupMenu <> FPopupMenu then
        raise Exception.Create('The PopupMenu of the RichEdit has been ' +
        'replaced after the SpellChecker was created.');

    ASuggestions := TStringList.Create;
    try
      Suggest(AMisspelledWord, ASuggestions);
      for S in ASuggestions do
          FSpellMenuItem.Add(TSpellWordMenuItem.Create(AMisspelledWord, S,
          AStartIndex, ASpellingError, SpellWordMenuItemClick))
    finally
      FreeAndNil(ASuggestions);
    end;

    AMenuItem := TMenuItem.Create(nil);
    FSpellMenuItem.Add(AMenuItem);
    AMenuItem.Caption := '-';

    case TSpellingError.GetCorrectiveAction(ASpellingError) of
      secaSuggestions, secaReplace, secaDelete:
        begin
          FSpellMenuItem.Add(TSpellAddIgnoreMenuItem.Create(AMisspelledWord,
            'Add', SpellAddMenuItemClick));
          FSpellMenuItem.Add(TSpellAddIgnoreMenuItem.Create(AMisspelledWord,
            'Ignore', SpellIgnoreMenuItemClick));
          FSpellMenuItem.Add(TSpellWordMenuItem.Create(AMisspelledWord,
            'Delete', AStartIndex, ASpellingError, SpellDeleteMenuItemClick));
        end;
    end;
  end;

  procedure MakeSpellMenuItemVisible(Value: Boolean);
  begin
    if Value then
    begin
      FSpellMenuItem.Visible := True;
      if Assigned(FOwnedPopupMenu) and Assigned(FSpellMenuItem.Action) then
        // Assigned(FOwnedPopupMenu) means that there was originally no popup.
          FSpellMenuItem.Action.Execute;
    end else begin
      FSpellMenuItem.Visible := False;
      FSpellMenuItem.Clear;
    end;
  end;

var
  AStartIndex: Integer;
  AWord: string;
  ASpellingError: ISpellingError;
begin
  if SpellChecking then
  begin
    // Find the word under the mouse
    AStartIndex := FindStartIndex(AMousePos);
    AWord := FindWord(AStartIndex);
  end else begin
    AStartIndex := 0;
  end;

  if (not SpellChecking) or (AWord = '') then
  begin
    // Call the original context popup
    MakeSpellMenuItemVisible(False);
    if Assigned(FOrigContextPopup) then
        FOrigContextPopup(ASender, AMousePos, AHandled);
  end else begin
    // Check the spelling
    ASpellingError := NextError(CheckSpelling(AWord, False));
    if Assigned(ASpellingError) then
    begin
      if FUseRichEditSpellCheck then
      begin
        MakeSpellMenuItemVisible(Assigned(FSpellMenuItem.Action) and
          (FSpellMenuItem.Action as TContainedAction).Enabled);
      end else begin
        BuildSpellMenu(AWord, AStartIndex, ASpellingError);
        MakeSpellMenuItemVisible(FSpellMenuItem.Count > 0);
      end;
    end else begin
      FPopupMenu.CloseMenu;
      MakeSpellMenuItemVisible(False);
    end;
  end;
end;

class function TSpellChecker.FindIndex(ARichEdit: TCustomRichEdit;
  AMousePos: TPoint): NativeInt;
// Find the Index at the mouse coords in ARichEdit
begin
  if (AMousePos.X <= 0) or (AMousePos.Y <= 0) then
  begin
    Result := ARichEdit.SelStart;
  end else begin
    Result := ARichEdit.Perform(EM_CHARFROMPOS, 0, LPARAM(@AMousePos));
  end;
end;

class function TSpellChecker.FindStartIndex(ARichEdit: TCustomRichEdit;
  AIndex: NativeInt): NativeInt;
begin
  // Handle ACharPos is not on an actual word
  if (AIndex < 0) or (ARichEdit.Perform(EM_FINDWORDBREAK, WB_CLASSIFY, AIndex)
    and (WBF_ISWHITE or WBF_BREAKLINE) <> 0) then Exit(AIndex);
  // Get the start index of the word we are on
  Result := ARichEdit.Perform(EM_FINDWORDBREAK, WB_MOVEWORDLEFT, AIndex + 1);
  // +1 to include the character we are on.
end;

class function TSpellChecker.FindStartIndex(ARichEdit: TCustomRichEdit;
  AMousePos: TPoint): NativeInt;
// Find the Start Index of the word at the mouse coords in ARichEdit
begin
  Result := FindStartIndex(ARichEdit, FindIndex(ARichEdit, AMousePos));
end;

function TSpellChecker.FindStartIndex(AMousePos: TPoint): NativeInt;
begin
  Result := FindStartIndex(FRichEdit, AMousePos);
end;

function TSpellChecker.FindStartIndex(AIndex: NativeInt): NativeInt;
begin
  Result := FindStartIndex(FRichEdit, AIndex);
end;

class function TSpellChecker.FindEndIndex(ARichEdit: TCustomRichEdit;
  AIndex: NativeInt): NativeInt;
begin
  Result := ARichEdit.Perform(EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, AIndex);
end;

function TSpellChecker.FindEndIndex(AIndex: NativeInt): NativeInt;
begin
  Result := FindEndIndex(FRichEdit, AIndex);
end;

class function TSpellChecker.FindTextRange(ARichEdit: TCustomRichEdit;
  AStartPos, AEndPos: NativeInt): string;
// Return the Text from AStartPos to AEndPos in FRichEdit
var
  ATextRange: TTextRangeW;
begin
  if AStartPos >= AEndPos then Exit('');
  SetLength(Result, AEndPos - AStartPos);
  ATextRange.chrg.cpMin := AStartPos;
  ATextRange.chrg.cpMax := AEndPos;
  ATextRange.lpstrText := PChar(Result);
  SetLength(Result, ARichEdit.Perform(EM_GETTEXTRANGE, 0, LPARAM(@ATextRange)));
end;

function TSpellChecker.FindTextRange(AStartPos, AEndPos: NativeInt): string;
begin
  Result := FindTextRange(FRichEdit, AStartPos, AEndPos);
end;

class function TSpellChecker.FindWord(ARichEdit: TCustomRichEdit;
  AStartIndex: NativeInt): string;
// Find the word starting at the index in ARichEdit
// If you pass in an Index that's not the start, you will get half a word!
var
  AEndIndex: NativeInt;
begin
  // Get the end index of the word we are on
  AEndIndex := FindEndIndex(ARichEdit, AStartIndex);
  // Retrieve the word we are on, from start index to end index
  Result := FindTextRange(ARichEdit, AStartIndex, AEndIndex).TrimRight;
end;

function TSpellChecker.FindWord(AIndex: NativeInt): string;
begin
  Result := FindWord(FRichEdit, AIndex);
end;

function TSpellChecker.FindWord(AMousePos: TPoint): string;
begin
  Result := FindWord(FindStartIndex(AMousePos));
end;

function TSpellChecker.GetSpellChecking: Boolean;
// Logic derived from TRichEditSpellCheck.ExecuteTarget
begin
  Result := TRichEdit(FRichEdit).SpellChecking and
    (not TRichEdit(FRichEdit).ReadOnly);
end;

function TSpellChecker.NextError(AEnumSpellingError: IEnumSpellingError)
  : ISpellingError;
begin
  if AEnumSpellingError.Next(Result) <> S_OK then Result := nil;
end;

function TSpellChecker.CheckSpelling(AText: string; AComprehensive: Boolean)
  : IEnumSpellingError;
// Execute a spell check of the text passed in. Return the first issue, if any
// are found, or nil if there are no issues
begin
  if AText = '' then Exit(nil);
  if AComprehensive then
      CheckOSError(FSpellChecker.ComprehensiveCheck(PWideChar(AText), Result))
  else CheckOSError(FSpellChecker.Check(PWideChar(AText), Result));
end;

function TSpellChecker.Execute(AComprehensive: Boolean): TModalResult;
// Execute a full spell check of either the selected part (if there is a
// selected part) or the entire TRichEdit
begin
  Result := SpellCheck.FSpell.TfrmSpell.Execute(Self, AComprehensive);
end;

procedure TSpellChecker.SpellWordMenuItemClick(Sender: TObject);
begin
  Replace((Sender as TSpellWordMenuItem).StartIndex,
    (Sender as TSpellWordMenuItem).Length, (Sender as TSpellWordMenuItem)
    .CorrectWord);
end;

procedure TSpellChecker.SpellAddMenuItemClick(Sender: TObject);
begin
  Add((Sender as TSpellMenuItem).MisspelledWord);
end;

procedure TSpellChecker.SpellIgnoreMenuItemClick(Sender: TObject);
begin
  Ignore((Sender as TSpellMenuItem).MisspelledWord);
end;

procedure TSpellChecker.SpellDeleteMenuItemClick(Sender: TObject);
begin
  Replace((Sender as TSpellWordMenuItem).StartIndex,
    (Sender as TSpellWordMenuItem).Length, '');
end;

procedure TSpellChecker.Replace(AStartIndex, ALength: Integer;
  const AWord: string);
var
  AOldMask, AOldSelStart, AOldSelLength: Integer;
begin
  AOldMask := FRichEdit.Perform(EM_SETEVENTMASK, 0, 0);
  try
    //    CheckOSError(FRichEdit.Perform(WM_SETREDRAW, Ord(False), 0));
    //    try
    AOldSelLength := FRichEdit.SelLength;
    try
      AOldSelStart := FRichEdit.SelStart;
      try
        FRichEdit.SelStart := AStartIndex;
        FRichEdit.SelLength := ALength;
        FRichEdit.SelText := AWord;
      finally
        FRichEdit.SelStart := AOldSelStart;
      end;
    finally
      FRichEdit.SelLength := AOldSelLength;
    end;
    //    finally
    //      CheckOSError(FRichEdit.Perform(WM_SETREDRAW, Ord(True), 0));
    //      InvalidateRect(FRichEdit.Handle, nil, True);
    //    end;
  finally
    FRichEdit.Perform(EM_SETEVENTMASK, 0, AOldMask);
  end;
end;

procedure TSpellChecker.Add(const AWord: string);
begin
  CheckOSError(FSpellChecker.Add(PWideChar(AWord)));
end;

procedure TSpellChecker.Ignore(const AWord: string);
begin
  CheckOSError(FSpellChecker.Ignore(PWideChar(AWord)));
end;

procedure TSpellChecker.Suggest(const AWord: string; ASuggestions: TStrings);
// AWord: the word that needs suggestions
// ASuggestions: The list to be filled with suggestions (pass in an empty
//   TStringList)
var
  AEnumString: IEnumString;
  APWideChar: PWideChar;
  AFetched: LongInt;
begin
  if (AWord = '') then Exit;
  if not Assigned(ASuggestions) then
      raise Exception.Create('ASuggestions not assigned');
  if FSpellChecker.Suggest(PChar(AWord), AEnumString) <> S_OK then Exit;

  APWideChar := '';
  while AEnumString.Next(1, APWideChar, @AFetched) = S_OK do
  begin
    if AFetched >= 1 then
    begin
      try
        ASuggestions.Add(APWideChar);
      finally
        CoTaskMemFree(APWideChar);
      end;
    end;
  end;
end;

constructor TSpellMenuItem.Create;
begin
  inherited Create(nil);
end;

constructor TSpellMenuItem.Create(AOwner: TComponent);
begin
  raise Exception.Create('This constructor is not implemented. ' +
    'Use the protected constructor instead');
end;

constructor TSpellWordMenuItem.Create(const AMisspelledWord,
  ACorrectWord: string; AStartIndex: NativeInt; ASpellingError: ISpellingError;
  AOnClick: TNotifyEvent = nil);
begin
  inherited Create;
  Caption := ACorrectWord;
  FMisspelledWord := AMisspelledWord;
  FCorrectWord := ACorrectWord;
  FStartIndex := AStartIndex;
  ASpellingError.Get_Length(FLength);
  OnClick := AOnClick;
end;

constructor TSpellAddIgnoreMenuItem.Create(const AMisspelledWord,
  ACaption: string; AOnClick: TNotifyEvent = nil);
begin
  inherited Create;
  Caption := ACaption;
  FMisspelledWord := AMisspelledWord;
  OnClick := AOnClick;
end;

constructor TSpellingError.Create(ARichEdit: TCustomRichEdit;
  ASpellingError: ISpellingError; ADisplacement: NativeInt = 0);
begin
  if not Assigned(ARichEdit) then
      raise Exception.Create('ARichEdit not Assigned');
  if not Assigned(ASpellingError) then
      raise Exception.Create('ASpellingError not Assigned');
  FRichEdit := ARichEdit;
  FSpellingError := ASpellingError;
  FDisplacement := ADisplacement;
  FMisspelledWord := GetMisspelledWord(FSpellingError, FRichEdit,
    FDisplacement);
end;

function TSpellingError.GetMisspelledWord: string;
begin
  Result := FMisspelledWord;
end;

function TSpellingError.GetStartIndex: LongWord;
begin
  Result := GetStartIndex(FSpellingError, FDisplacement);
end;

function TSpellingError.GetLength: LongWord;
begin
  Result := GetLength(FSpellingError);
end;

function TSpellingError.GetCorrectiveAction: TCorrectiveAction;
begin
  Result := GetCorrectiveAction(FSpellingError);
end;

class function TSpellingError.GetMisspelledWord(ASpellingError: ISpellingError;
  ARichEdit: TCustomRichEdit; ADisplacement: NativeInt = 0): string;
begin
  Result := TSpellChecker.FindWord(ARichEdit, GetStartIndex(ASpellingError,
    ADisplacement));
end;

class function TSpellingError.GetStartIndex(ASpellingError: ISpellingError;
  ADisplacement: NativeInt = 0): LongWord;
var
  I: Int64;
begin
  CheckOSError(ASpellingError.Get_StartIndex(Result));
  I := Int64(Result) + ADisplacement;
  if I >= 0 then Result := LongWord(I) else Result := 0;
end;

class function TSpellingError.GetLength(ASpellingError: ISpellingError)
  : LongWord;
begin
  CheckOSError(ASpellingError.Get_Length(Result));
end;

class function TSpellingError.GetCorrectiveAction(ASpellingError
  : ISpellingError): TCorrectiveAction;
var
  ACorrectiveAction: CORRECTIVE_ACTION;
begin
  CheckOSError(ASpellingError.Get_CorrectiveAction(ACorrectiveAction));
  Result := TCorrectiveAction(ACorrectiveAction);
end;

type
  __TCustomRichEdit = class(TCustomRichEdit);

  TCustomRichEditSpellcheckHelper = class(TObject)
    FRichEdit: TCustomRichEdit;
    FDefParentProc: TWindowProcPtr;
    procedure ParentWndProc(var message: TMessage);
  end;

procedure TCustomRichEditSpellcheckHelper.ParentWndProc(var message: TMessage);
begin
  if message.Msg = WM_CONTEXTMENU then message.Result := 1
  else message.Result := CallWindowProc(FDefParentProc, FRichEdit.Parent.Handle,
      message.Msg, message.WParam, message.LPARAM);
end;

procedure TSpellCheckAction.ExecuteTarget(Target: TObject);
// Code derived from Vcl.ComCtrls.TCustomRichEdit_ShowSpellCheckMenu
var
  LParentInstance: Pointer;
  LHelper: TCustomRichEditSpellcheckHelper;
begin
  if Target is TCustomRichEdit then
  begin
    with __TCustomRichEdit(Target) do
    begin
      if not(SpellChecking and HandleAllocated and Visible and (SelStart > 0))
      then Exit;
      if (Parent <> nil) and Parent.HandleAllocated then
      begin
        LHelper := TCustomRichEditSpellcheckHelper.Create;
        LHelper.FRichEdit := __TCustomRichEdit(Target);
        LHelper.FDefParentProc :=
          TWindowProcPtr(GetWindowLong(Parent.Handle, GWL_WNDPROC));
        LParentInstance := MakeObjectInstance(LHelper.ParentWndProc);
        SetWindowLong(Parent.Handle, GWL_WNDPROC,
          Winapi.Windows.LPARAM(LParentInstance));
      end else begin
        LHelper := nil;
        LParentInstance := nil;
      end;
      try
        CallWindowProc(DefWndProc, Handle, WM_CONTEXTMENU, Handle,
          PointToLParam(Mouse.CursorPos));
      finally
        if LHelper <> nil then
        begin
          SetWindowLong(Parent.Handle, GWL_WNDPROC,
            Winapi.Windows.LPARAM(LHelper.FDefParentProc));
          FreeObjectInstance(LParentInstance);
          LHelper.Free;
        end;
      end;
    end;
  end;
end;

end.
