Using MS Word as a Spelling and Grammar Checker for Delphi

The COM interface exposed by MS Word gives a number of mechanisms for the use of the spelling engine.

• The Word.Application object can call the engine for a single word or string. The return value is a Boolean indicating True (no errors) or False (errors). Further work must be done to provide spelling suggestions / correction.
• The Document object contained by the Word.Application object exposes all the functionality of MS Word, in particular, the MS Word dialog boxes for spelling and grammar checking can be used.

The technique used in this component is the second method. Text is copied to the (hidden) word document, then the appropriate function (spelling or grammar) is called. To discover if the user made any changes to the text, MS Word's ability to track changes is utilised.

RTF text can be checked easily by using the CheckClipBoardSpell / Grammar functions.

Custom Dictionaries: Using custom dictionaries is a powerful feature of Word's spelling checker but there appears to be an error in the documentation (at least I can't get it to work as written in Delphi or VBA within Word itself!). Custom dictionaries are text files (usually with a '.dic' extension) with a sorted list of words - one word on each line. Included the ability to "install" a custom dictionary(s) which will be used in all spell checks. The down side is that the dictionary will now be seen by Word all the time, so it's probably a good idea to remove any such dictionary before exiting your program.

Checking if the user wants to cancel spell/grammar checking: In your own program you could check for the press of a "cancel" button or key. This isn't available when using Word's built in dialogs, so I tend to use the SpellingChecked and GrammarChecked properties to check if there are still errors in the text after a spell check has been completed. If the user has decided to quit, these properties should be False. I have mapped them into the UserCancel property for ease of programming.

Installation is very simple, just copy the code and save it as uSpellCheck.pas and include any of your existing/new dpk file.

How to use:
i) Drop the TActionList component onto a form.
ii) Select StandardAction from TActionList
iii)You will see new TSpellCheck action item under Edit category. select it ;-)
By default this action item is associated with F7 shortcut.
iv) Drop few Editable controls like TEdit, TMemo, TRichEdit etc and run the application and press F7 to trigger Spell Check.

That's it really!

{
Unit Name   : uSpellCheck.pas
Description : TSpellCheck is derived from TEditAction, which is available on
              TActionList. This newly created action acts as a standard EditAction
              for example: It gets enabled when the control is in Editable mode.
Enhancements: Couldn't think of any more as of now...
Create Date : 1st December 2010
Author      : Kiran Kumar Kurapaty
Code enhanced from original author: Andrew Baylis (ajbaylis@melbpc.org.au), Thanks Andrew.
}

unit uSpellCheck;

interface

uses Windows, SysUtils, Classes, ActnList, Forms, StdCtrls, Dialogs, StdActns, ActnRes, Messages, ComObj,
     ActiveX, Variants;

type
  TWordTimer = class(TThread)
  private
    FCaption: string;
    FDelay: Integer;
    FDialogWndClass: string;
    FPopUpExists: Boolean;
    procedure SetDelay(Value: Integer);
  protected
    procedure Execute; override;
  public
    constructor Create(CreateSuspended: Boolean);
    procedure Resume;
    property Caption: string read FCaption write FCaption;
    property Delay: Integer read FDelay write SetDelay;
    property DialogWndClass: string read FDialogWndClass write FDialogWndClass;
  end;

  TSpellLanguage = Integer;

  TSpellCheck = class(TEditAction)
  private
    FCancel: Boolean;
    FChangedText: string;
    FConnected: Boolean;
    FHandle: HWND;
    FNumChanges: Integer;
    FOleOn: Boolean;
    FSpellCaption: string;
    FTimer: TWordTimer;
    FUseSpellCaption: Boolean;
    FWordApp, FRange, FWordDoc, FCustDics: OLEVariant;
    FWordDialogClass: string;
    FWordVersion: string;
    FLanguage: TSpellLanguage;
    function GetCheckGWS: Boolean;
    function GetGrammarErrors: Integer;
    function GetSpellChecked: Boolean;
    function GetSpellErrors: Integer;
    function GetUserCancel: Boolean;
    function GetVersion: string;
    function GetWordVersion: string;
    procedure SetCheckGWS(const Value: Boolean);
    procedure SetLanguage(Value: TSpellLanguage);
  protected
    function Internal_checkGrammar: Boolean;
    function Internal_checkSpelling: Boolean;
    procedure StartTimer;
    procedure StopTimer;
  public
    procedure ExecuteTarget(Target: TObject); override;
    procedure UpdateTarget(Target: TObject); override;

    function AddCustomDic(const FileName: string): Integer;
    function CheckClipboardGrammar: Boolean;
    function CheckClipboardSpell: Boolean;
    function CheckGrammar(const Text: string): Boolean;
    function CheckSpelling(const Text: string): Boolean;
    procedure ClearText;
    procedure Connect;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Disconnect;
    procedure RemoveCustomDic(const Name: string); overload;
    procedure RemoveCustomDic(const Index: Integer); overload;
    procedure ResetIgnoreAll;
    procedure SpellingOptions;

    property ChangedText: string read FChangedText;
    property CheckGrammarWithSpelling: Boolean read GetCheckGWS write SetCheckGWS;
    property Connected: Boolean read FConnected;
    property GrammarErrorCount: Integer read GetGrammarErrors;
    property NumChanges: Integer read FNumChanges;
    property SpellChecked: Boolean read GetSpellChecked;
    property SpellErrorCount: Integer read GetSpellErrors;
    property UserCancelled: Boolean read GetUserCancel write FCancel;
    property WordVersion: string read GetWordVersion;
  published
    property SpellCaption: string read FSpellCaption write FSpellCaption;
    property UseSpellCaption: Boolean read FUseSpellCaption write FUseSpellCaption;
    property Version: string read GetVersion;
    property Language: TSpellLanguage read FLanguage write SetLanguage;
  end;

  LangRecord = record
    LocalName: string;
    ID: Integer;
  end;

const // Spelling Language
   SpellLanguage: array[0..63] of LangRecord =
      ((LocalName: 'LanguageNone'; ID: $00000000),
      (LocalName: 'NoProofing '; ID: $00000400),
      (LocalName: 'Danish '; ID: $00000406),
      (LocalName: 'German '; ID: $00000407),
      (LocalName: 'SwissGerman '; ID: $00000807),
      (LocalName: 'EnglishAUS '; ID: $00000C09),
      (LocalName: 'EnglishUK '; ID: $00000809),
      (LocalName: 'EnglishUS '; ID: $00000409),
      (LocalName: 'EnglishCanadian '; ID: $00001009),
      (LocalName: 'EnglishNewZealand '; ID: $00001409),
      (LocalName: 'EnglishSouthAfrica '; ID: $00001C09),
      (LocalName: 'Spanish '; ID: $0000040A),
      (LocalName: 'French '; ID: $0000040C),
      (LocalName: 'FrenchCanadian '; ID: $00000C0C),
      (LocalName: 'Italian '; ID: $00000410),
      (LocalName: 'Dutch '; ID: $00000413),
      (LocalName: 'NorwegianBokmol '; ID: $00000414),
      (LocalName: 'NorwegianNynorsk '; ID: $00000814),
      (LocalName: 'BrazilianPortuguese '; ID: $00000416),
      (LocalName: 'Portuguese '; ID: $00000816),
      (LocalName: 'Finnish '; ID: $0000040B),
      (LocalName: 'Swedish '; ID: $0000041D),
      (LocalName: 'Catalan '; ID: $00000403),
      (LocalName: 'Greek '; ID: $00000408),
      (LocalName: 'Turkish '; ID: $0000041F),
      (LocalName: 'Russian '; ID: $00000419),
      (LocalName: 'Czech '; ID: $00000405),
      (LocalName: 'Hungarian '; ID: $0000040E),
      (LocalName: 'Polish '; ID: $00000415),
      (LocalName: 'Slovenian '; ID: $00000424),
      (LocalName: 'Basque '; ID: $0000042D),
      (LocalName: 'Malaysian '; ID: $0000043E),
      (LocalName: 'Japanese '; ID: $00000411),
      (LocalName: 'Korean '; ID: $00000412),
      (LocalName: 'SimplifiedChinese '; ID: $00000804),
      (LocalName: 'TraditionalChinese '; ID: $00000404),
      (LocalName: 'SwissFrench '; ID: $0000100C),
      (LocalName: 'Sesotho '; ID: $00000430),
      (LocalName: 'Tsonga '; ID: $00000431),
      (LocalName: 'Tswana '; ID: $00000432),
      (LocalName: 'Venda '; ID: $00000433),
      (LocalName: 'Xhosa '; ID: $00000434),
      (LocalName: 'Zulu '; ID: $00000435),
      (LocalName: 'Afrikaans '; ID: $00000436),
      (LocalName: 'Arabic '; ID: $00000401),
      (LocalName: 'Hebrew '; ID: $0000040D),
      (LocalName: 'Slovak '; ID: $0000041B),
      (LocalName: 'Farsi '; ID: $00000429),
      (LocalName: 'Romanian '; ID: $00000418),
      (LocalName: 'Croatian '; ID: $0000041A),
      (LocalName: 'Ukrainian '; ID: $00000422),
      (LocalName: 'Byelorussian '; ID: $00000423),
      (LocalName: 'Estonian '; ID: $00000425),
      (LocalName: 'Latvian '; ID: $00000426),
      (LocalName: 'Macedonian '; ID: $0000042F),
      (LocalName: 'SerbianLatin '; ID: $0000081A),
      (LocalName: 'SerbianCyrillic '; ID: $00000C1A),
      (LocalName: 'Icelandic '; ID: $0000040F),
      (LocalName: 'BelgianFrench '; ID: $0000080C),
      (LocalName: 'BelgianDutch '; ID: $00000813),
      (LocalName: 'Bulgarian '; ID: $00000402),
      (LocalName: 'MexicanSpanish '; ID: $0000080A),
      (LocalName: 'SpanishModernSort '; ID: $00000C0A),
      (LocalName: 'SwissItalian '; ID: $00000810));


  procedure Register;

implementation

uses Registry;

{ TSpellCheck }
procedure TSpellCheck.ExecuteTarget(Target: TObject);
begin
  if Assigned(GetControl(Target)) then
  begin
    try
      if CheckSpelling(GetControl(Target).Text) then
        GetControl(Target).Text := ChangedText;
    except
      on E:Exception do
        MessageDlg(Format('There was an error calling the Spell Checker (%s) - '+
                          'you may need to close some Windows Applications and try again',
                          [E.message]), mtError, [mbOk], 0);
    end;
  end;
end;

procedure TSpellCheck.UpdateTarget(Target: TObject);
begin
  inherited;
  Enabled := Length(GetControl(Target).Text) > 0;
end;



type
  TSpellCheckActionClass = class of TSpellCheck;
  TEditActionClass = class of TEditAction;

  TEditActionWrapper = class(StdActns.TEditAction);

  TSpellCheckEditActionInfo = record
    SpellCheckActionClass: TSpellCheckActionClass;
    EditActionClass: TEditActionClass;
    DefaultCaption: string;
    DefaultHint: string;
    DefaultImageIndex: Integer;
    DefaultShortCut: TShortCut;
  end;

  TStandardActionsEx = class(TStandardActions)
  protected
    procedure CreateByInfo(AEditActionsInfo: TSpellCheckEditActionInfo);
    function FindEditActionByClassType(AEditActionClass: TEditActionClass): TEditAction;
  public
    constructor Create(AOwner: TComponent); override;
  end;

{purpose: Add default properties of future actions here...}
const
  CH4EditActionsCount = 1;
  CH4EditActionsInfo: array [0..CH4EditActionsCount-1] of TSpellCheckEditActionInfo =
  (
    ( SpellCheckActionClass: TSpellCheck;
      EditActionClass: TEditAction;
      DefaultCaption: '&Spell Check';
      DefaultHint: 'Spell Check|Check for Spellings and Grammer.';
      DefaultImageIndex: -1;
      DefaultShortCut: VK_F7)
  );

constructor TStandardActionsEx.Create(AOwner: TComponent);
var
  I: Integer;
begin
  inherited;
  for I := Low(CH4EditActionsInfo) to High(Ch4EditActionsInfo) do
    CreateByInfo(CH4EditActionsInfo[I]);
end;

procedure TStandardActionsEx.CreateByInfo(AEditActionsInfo: TSpellCheckEditActionInfo);
var
  AEditAction: TEditAction;
  ASpellCheckEditAction: TEditAction;
begin
  AEditAction := FindEditActionByClassType(AEditActionsInfo.EditActionClass);
  ASpellCheckEditAction := AEditActionsInfo.SpellCheckActionClass.Create(Self);
  with ASpellCheckEditAction do
  begin
    if AEditAction <> nil then
    begin
      Caption := TEditActionWrapper(AEditAction).Caption;
      Hint := TEditActionWrapper(AEditAction).Hint;
      ImageIndex := TEditActionWrapper(AEditAction).ImageIndex;
      ShortCut := TEditActionWrapper(AEditAction).ShortCut;
    end
    else
    begin
      Caption := AEditActionsInfo.DefaultCaption;
      Hint := AEditActionsInfo.DefaultHint;
      ImageIndex := AEditActionsInfo.DefaultImageIndex;
      ShortCut := AEditActionsInfo.DefaultShortCut;
    end;
  end;
end;

function TStandardActionsEx.FindEditActionByClassType(AEditActionClass: TEditActionClass): TEditAction;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to ComponentCount - 1 do
    if (Components[I].ClassType = AEditActionClass) and (Components[I] is TEditAction) then
    begin
      Result := Components[I] as TEditAction;
      Break;
    end;
end;

procedure Register;
begin
  RegisterActions('Edit', [TSpellCheck], TStandardActionsEx);
end;

// these constants used to identify the window class of Word's dialog box
const
  //Constants for MS Word
   MSDialogWndClass2000 = 'bosa_sdm_Microsoft Word 9.0';
   MSDialogWndClass97 = 'bosa_sdm_Microsoft Word 8.0';
   MSWordWndClass = 'OpusApp';
   CSpellerVersion = '1.0';

function IsWordPresent: Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    Result := Reg.KeyExists('Word.Application');
  finally
    Reg.Free;
  end;
end;

{ TSpellCheck }
function TSpellCheck.GetCheckGWS: Boolean;
begin
  Result := False;
  if FConnected then Result := FWordApp.Options.CheckGrammarWithSpelling;
end;

function TSpellCheck.GetGrammarErrors: Integer;
begin
  if FConnected then
    Result := FRange.GrammaticalErrors.Count
  else
    Result := 0;
end;

function TSpellCheck.GetSpellChecked: Boolean;
// returns false if spelling has yet to be checked
begin
  Result := True;
  if FConnected then Result := not FRange.SpellingChecked;
end;

function TSpellCheck.GetSpellErrors: Integer;
begin
  if FConnected then
    Result := FRange.SpellingErrors.Count
  else
    Result := 0;
end;

function TSpellCheck.GetUserCancel: Boolean;
begin
  Result := FCancel;
end;

function TSpellCheck.GetVersion: string;
begin
  Result := CSpellerVersion;
end;

function TSpellCheck.GetWordVersion: string;
begin
  Result := FWordVersion;
end;

procedure TSpellCheck.SetCheckGWS(const Value: Boolean);
begin
  if FConnected then FWordApp.Options.CheckGrammarWithSpelling := Value;
end;

function TSpellCheck.Internal_checkGrammar: Boolean;
begin
  SetWindowPos(FHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE + SWP_HIDEWINDOW); // ensures dialogs appear in front
  FWordDoc.TrackRevisions := True; // note if changes are made
  FNumChanges := 0;

  FRange.GrammarChecked := False;
  if (FLanguage > 0) then // 0 means use the default setting
    FRange.LanguageID := SpellLanguage[FLanguage].ID;

  StartTimer;
  OleCheck(FRange.CheckGrammar);
  StopTimer;

  FCancel := not FRange.GrammarChecked;
  FWordApp.Visible := False; // need to stop ActiveDocument appearing

  FNumChanges := FRange.Revisions.Count; // seems revisions counts the old word and the new one separately
  Result := (FRange.Revisions.Count > 0);
  if Result then FRange.Revisions.AcceptAll; // accept all changes

  FWordDoc.TrackRevisions := False; // don't track future changes
end;

function TSpellCheck.Internal_checkSpelling: Boolean;
begin
  SetWindowPos(FHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE + SWP_HIDEWINDOW); // ensures dialogs appear in front
  FWordDoc.TrackRevisions := True; // note if changes are made
  FNumChanges := 0;

  if (FLanguage > 0) then // 0 means use the default setting
     FRange.LanguageID := SpellLanguage[FLanguage].ID;

  StartTimer;
  OleCheck(FWordDoc.CheckSpelling);
  StopTimer;

  FCancel := not FWordDoc.SpellingChecked;
  FWordApp.Visible := False; // need to stop ActiveDocument appearing

  FNumChanges := FRange.Revisions.Count; // seems revisions counts the old word and the new one separately
  Result := (FRange.Revisions.Count > 0);
  if Result then FRange.Revisions.AcceptAll; // accept all changes

  FWordDoc.TrackRevisions := False; // don't track future changes
end;

procedure TSpellCheck.StartTimer;
begin
  if FUseSpellCaption then
  begin
    FTimer.Caption := FSpellCaption;
    FTimer.Resume;
  end;
end;

procedure TSpellCheck.StopTimer;
begin
  FTimer.Suspend;
end;

function TSpellCheck.AddCustomDic(const FileName: string): Integer;
begin
  FCustDics.Add(FileName);
  Result := FCustDics.Count;
end;

function TSpellCheck.CheckClipboardGrammar: Boolean;
// returns true if changes were made. Corrected text is on the clipboard
begin
   Result := False;
   if not FConnected then Connect;
   if not FConnected then Exit; // if still not connected then no MS Word!

   if FConnected then
   begin
      FRange.Paste; // replace with new text to check
      Result := Internal_CheckGrammar;
      if Result then FRange.Copy;
   end;
end;

function TSpellCheck.CheckClipboardSpell: Boolean;
// returns true if changes were made. Corrected text is on the clipboard
begin
   Result := False;
   if not FConnected then Connect;
   if not FConnected then Exit; // if still not connected then no MS Word!
   if FConnected then
   begin
      FRange.Paste; // replace with new text to check
      Result := Internal_checkSpelling;
      if Result then FRange.Copy; // put onto clipboard
   end;
end;

function TSpellCheck.CheckGrammar(const Text: string): Boolean;
// returns true if changes were made and the corrected text is placed in the Text string
begin
   Result := False;
   if not FConnected then Connect;
   if not FConnected then Exit; // if still not connected then no MS Word!
   if FConnected then
   begin
      FChangedText := EmptyStr;
      FRange.Text := Text; // replace with new text to check
      Result := Internal_CheckGrammar;
      if Result then FChangedText := FRange.Text;
   end;
end;

function TSpellCheck.CheckSpelling(const Text: string): Boolean;
// returns true if changes were made and the corrected text is placed in the Text string
begin
   Result := False;
   if not FConnected then Connect;
   if not FConnected then Exit; // if still not connected then no MS Word!
   if FConnected then
   begin
      FChangedText := EmptyStr;
      FRange.Text := Text; // replace with new text to check
      Result := Internal_CheckSpelling;
      if Result then FChangedText := FRange.Text;
   end
   else
      Result := False;
end;

procedure TSpellCheck.ClearText;
begin
  if FConnected then FRange.Text := EmptyStr;
end;

procedure TSpellCheck.Connect;
var
  s: string;
begin
  if FConnected then Exit; // don't create two instances
  try
    FWordApp := CreateOleObject('Word.Application');
    FConnected := True;
    FWordApp.Visible := False; // hides the application
    FWordApp.ScreenUpdating := False; // speed up winword's processing
    FWordApp.WindowState := $00000002; // minimise
    FWordDoc := FWordApp.Documents.Add(EmptyParam, False); // this will hold the text to be checked
    FRange := FWordDoc.Range;
    FRange.WholeStory; // makes FRange point to all text in document
    FCustDics := FWordApp.CustomDictionaries;
    FWordVersion := FWordApp.Version;
    s := FWordDoc.Name + ' - ' + FWordApp.Name;
    FHandle := FindWindow(MSWordWndClass, PChar(s)); // winword
    if FWordVersion[1] = '9' then
      FWordDialogClass := MSDialogWndClass2000
    else
      FWordDialogClass := MSDialogWndClass97;

    FTimer := TWordTimer.Create(True);
    FTimer.Delay := 50; // every 0.05 s
    FTimer.DialogWndClass := FWordDialogClass;
    FTimer.FreeOnTerminate := True;

  except
    FWordApp := Unassigned;
    FConnected := False;
    if Assigned(FTimer) then
    begin
      FTimer.Terminate;
      while FTimer.Suspended do
        FTimer.Resume;
    end;
    FTimer := nil;
    MessageDlg('Unable to initialise MS Word', mtError, [mbYes], 0);
  end;
end;

constructor TSpellCheck.Create(AOwner: TComponent);
var
  init: Integer;
begin
  inherited;
  FConnected := False;
  FCancel := False;
  FChangedText := EmptyStr;
  Init := CoInitialize(nil);
  if (Init = S_OK) or (Init = S_FALSE) then
    FOleOn := True
  else
    raise EOleSysError.CreateFmt('Error initialising COM library', []);

  FSpellCaption := EmptyStr;
  FUseSpellCaption := False;
  FLanguage := 0;
end;

destructor TSpellCheck.Destroy;
begin
  Disconnect;
  if FOleOn then CoUninitialize;
  inherited;
end;

procedure TSpellCheck.Disconnect;
var
  savechanges: OleVariant;
begin
  if not VarIsEmpty(FWordApp) then
  begin
    savechanges := False;
    FWordApp.Quit(savechanges); // don't save changes
    FRange := Unassigned;
    FWordDoc := Unassigned;
    FWordApp := Unassigned;
    FCustDics := Unassigned;
    FConnected := False;
    if Assigned(FTimer) then
    begin
      FTimer.Terminate;
      while FTimer.Suspended do
        FTimer.Resume; // need this in case thread was never started
    end;
    FTimer := nil;
  end;
end;

procedure TSpellCheck.RemoveCustomDic(const Name: string);
var
  dic: OleVariant;
begin
  dic := FCustDics.Item(Name);
  if not VarIsEmpty(dic) then
    dic.Delete;
  dic := Unassigned;
end;

procedure TSpellCheck.RemoveCustomDic(const Index: Integer);
var
  dic: OleVariant;
begin
  dic := FCustDics.Item(Index);
  if not VarIsEmpty(dic) then
    dic.Delete;
  dic := Unassigned;
end;

procedure TSpellCheck.ResetIgnoreAll;
begin
  if FConnected then
  begin
    FRange.Text := ''; // ResetIgnoreAll performs an automatic spell check
    FWordApp.ResetIgnoreAll;
  end;
end;

procedure TSpellCheck.SpellingOptions;
begin
  BringWindowToTop(FHandle); // ensures that dialog opens on top
  FWordApp.Dialogs.Item($000000D3).Show;
  FWordApp.Visible := False;
end;

procedure TSpellCheck.SetLanguage(Value: TSpellLanguage);
begin
  FLanguage := Value;
end;

{ TWordTimer }
procedure TWordTimer.SetDelay(Value: Integer);
begin
  if (Value > 0) then FDelay := Value;
end;

procedure TWordTimer.Execute;
var
  h: HWND;
begin
  while not Terminated do
  begin
    sleep(FDelay); // use this as a rough timer
    if (FDialogWndClass <> EmptyStr) then
    begin
      h := FindWindow(PChar(FDialogWndClass), nil);
      if (h <> 0) and (not FPopUpExists) then
      // only change caption if the window has just appeared
      begin
        SetWindowText(h, PChar(FCaption));
        FPopUpExists := True;
      end else
        FPopUpExists := False;
    end;
  end;
end;

constructor TWordTimer.Create(CreateSuspended: Boolean);
begin
  FDelay := 100; // default delay (ms)
  inherited Create(CreateSuspended);
end;

procedure TWordTimer.Resume;
begin
  FPopUpExists := False;
  inherited;
end;

end.