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.
