Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Проверка правописания и синонимов при помощи компонентов Microsoft Office

01.01.2007

This is the VCL for Spell Checking and Synonyms using MS Word COM interface. It can correct and replace words in a Text String,TMemo or TRichEdit using a built in replacement editor, or can be controlled by user dialog. I see there are other callable functions in the interface, which I have not implemented. Anyone see a use for any of them ?.

They are ...

    property PartOfSpeechList: OleVariant  read Get_PartOfSpeechList; 
    property
AntonymList: OleVariant read Get_AntonymList;
    property
RelatedExpressionList: OleVariant  read Get_RelatedExpressionList;
    property
RelatedWordList: OleVariant  read Get_RelatedWordList;

Example of checking and changing a Memo text ...

  SpellCheck.CheckMemoTextSpelling(Memo1);

Properties

----------------

LetterChars           - Characters considered to be letters. default is  

                                  ['A'..'Z','a'..'z'] (English) but could be changed to

                                  ['A'..'Z','a'..'z','б','й','н','у','ъ'] (Spanish)

Color                       - Backgound color of Default dialog Editbox and Listbox

CompletedMessage - Enable/Disable display of completed and count message dialog

Font                         - Font of Default dialog Editbox and Listbox

Language                - Language used by GetSynonyms() method

ReplaceDialog         - Use Default replace dialog or User defined  (see events)

Active                      - Readonly, set at create time. Indicates if MS Word is  available

Methods

----------------

function GetSynonyms(StrWord : string; Synonyms : TStrings) : boolean;

        True if synonyms found for StrWord. Synonyms List is  

        returned in TStrings (Synonyms).

function CheckWordSpelling(StrWord : string; Suggestions : TStrings) : boolean;

        True if StrWord is spelt correctly. Suggested corrections

        returned in TStrings (Suggestions)

procedure CheckTextSpelling(var StrText : string);

         Proccesses string StrText and allows users to change  

         mispelt  words via a Default replacement dialog or User  

         defined calls. Words are changed and returned in StrText.

         Words in the text are changed automatically by the Default

         editor. Use the  events if you want to control the dialog

         yourself. ie. Get the mispelt word, give a choice of

         sugesstions (BeforeCorrection), Change the word to

         corrected  (OnCorrection) and possibly display "Was/Now"

         (AfterCorrection)

procedure CheckRichTextSpelling(RichEdit : TRichEdit);

        Corrects misspelt words directly in TRichEdit.Text.

        Rich Format is maintained.

procedure CheckMemoTextSpelling(Memo : TMemo);

        Corrects misspelt words directly into a TMemo.Text.

Events (Mainly used when ReplaceDialog = repUser)

--------------------------------------------------------------------------------

BeforeCorrection - Supplies the mispelt word along with a TStrings

                                var containing suggested corrections.

OnCorrection       - Supplies the mispelt word as a VAR type allowing

                               user to change it to desired word. The word will be

                               replaced by this variable in the passed StrText.

AfterCorrection - Supplies the mispelt word and what it has been

                              changed to.

unit SpellChk;
interface
 
// =============================================================================
// MS Word COM Interface to Spell Check and Synonyms
// Mike Heydon Dec 2000
// mheydon@pgbison.co.za
// =============================================================================
 
uses
Windows, SysUtils, Classes, ComObj, Dialogs, Forms, StdCtrls,
 
Controls, Buttons, Graphics, ComCtrls, Variants;
 
// Above uses Variants is for Delphi 6 - remove for Delphi 5 and less
 
type
 
// Event definitions
 
TSpellCheckBeforeCorrection = procedure(Sender: TObject;
   
MispeltWord: string;
   
Suggestions: TStrings) of object;
 
 
TSpellCheckAfterCorrection = procedure(Sender: TObject;
   
MispeltWord: string;
   
CorrectedWord: string) of object;
 
 
TSpellCheckOnCorrection = procedure(Sender: TObject;
   
var WordToCorrect: string) of object;
 
 
// Property types
 
TSpellCheckReplacement = (repDefault, repUser);
 
TSpellCheckLetters = set of char;
 
 
TSpellCheckLanguage = (wdLanguageNone, wdNoProofing, wdDanish, wdGerman,
    wdSwissGerman
, wdEnglishAUS, wdEnglishUK, wdEnglishUS,
    wdEnglishCanadian
, wdEnglishNewZealand,
    wdEnglishSouthAfrica
, wdSpanish, wdFrench,
    wdFrenchCanadian
, wdItalian, wdDutch, wdNorwegianBokmol,
    wdNorwegianNynorsk
, wdBrazilianPortuguese,
    wdPortuguese
, wdFinnish, wdSwedish, wdCatalan, wdGreek,
    wdTurkish
, wdRussian, wdCzech, wdHungarian, wdPolish,
    wdSlovenian
, wdBasque, wdMalaysian, wdJapanese, wdKorean,
    wdSimplifiedChinese
, wdTraditionalChinese,
    wdSwissFrench
, wdSesotho, wdTsonga, wdTswana, wdVenda,
    wdXhosa
, wdZulu, wdAfrikaans, wdArabic, wdHebrew,
    wdSlovak
, wdFarsi, wdRomanian, wdCroatian, wdUkrainian,
    wdByelorussian
, wdEstonian, wdLatvian, wdMacedonian,
    wdSerbianLatin
, wdSerbianCyrillic, wdIcelandic,
    wdBelgianFrench
, wdBelgianDutch, wdBulgarian,
    wdMexicanSpanish
, wdSpanishModernSort, wdSwissItalian);
 
 
// Main TSpellcheck Class
 
TSpellCheck = class(TComponent)
 
private
   
MsWordApp,
     
MsSuggestions: OleVariant;
   
FLetterChars: TSpellCheckLetters;
   
FFont: TFont;
   
FColor: TColor;
   
FReplaceDialog: TSpellCheckReplacement;
   
FCompletedMessage,
     
FActive: boolean;
   
FLanguage: TSpellCheckLanguage;
   
FForm: TForm;
   
FEbox: TEdit;
   
FLbox: TListBox;
   
FCancelBtn,
     
FChangeBtn: TBitBtn;
   
FBeforeCorrection: TSpellCheckBeforeCorrection;
   
FAfterCorrection: TSpellCheckAfterCorrection;
   
FOnCorrection: TSpellCheckOnCorrection;
    procedure
SetFFont(NewValue: TFont);
 
protected
    procedure
MakeForm;
    procedure
CloseForm;
    procedure
SuggestedClick(Sender: TObject);
 
public
   
constructor Create(AOwner: TComponent); override;
    destructor
Destroy; override;
   
function GetSynonyms(StrWord: string; Synonyms: TStrings): boolean;
   
function CheckWordSpelling(StrWord: string;
     
Suggestions: TStrings): boolean;
    procedure
CheckTextSpelling(var StrText: string);
    procedure
CheckRichTextSpelling(RichEdit: TRichEdit);
    procedure
CheckMemoTextSpelling(Memo: TMemo);
    procedure
Anagrams(const InString: string; StringList: TStrings);
    property
Active: boolean read FActive;
    property
LetterChars: TSpellCheckletters read FLetterChars write FLetterChars;
  published
    property
Language: TSpellCheckLanguage read FLanguage
      write
FLanguage;
    property
CompletedMessage: boolean read FCompletedMessage
      write
FCompletedMessage;
    property
Color: TColor read FColor write FColor;
    property
Font: TFont read FFont write SetFFont;
    property
BeforeCorrection: TSpellCheckBeforeCorrection
      read
FBeforeCorrection
      write
FBeforeCorrection;
    property
AfterCorrection: TSpellCheckAfterCorrection
      read
FAfterCorrection
      write
FAfterCorrection;
    property
OnCorrection: TSpellCheckOnCorrection
      read
FOnCorrection
      write
FOnCorrection;
    property
ReplaceDialog: TSpellCheckReplacement
      read
FReplaceDialog
      write
FReplaceDialog;
 
end;
 
procedure
Register;
 
// -----------------------------------------------------------------------------
implementation
 
// Mapped Hex values for ord(FLanguage)
const
 
 
LanguageArray: array[0..63] of integer =
 
($0, $400, $406, $407, $807, $C09, $809, $409,
    $1009
, $1409, $1C09, $40A, $40C, $C0C, $410,
    $413
, $414, $814, $416, $816, $40B, $41D, $403,
    $408
, $41F, $419, $405, $40E, $415, $424, $42D,
    $43E
, $411, $412, $804, $404, $100C, $430, $431,
    $432
, $433, $434, $435, $436, $401, $40D, $41B,
    $429
, $418, $41A, $422, $423, $425, $426, $42F,
    $81A
, $C1A, $40F, $80C, $813, $402, $80A, $C0A, $810);
 
 
// Change to Component Pallete of choice
 
procedure
Register;
begin
 
RegisterComponents('MahExtra', [TSpellCheck]);
end;
 
// TSpellCheck
 
constructor TSpellCheck.Create(AOwner: TComponent);
begin
  inherited
Create(AOwner);
 
// Defaults
 
FLetterChars := ['A'..'Z', 'a'..'z'];
 
FCompletedMessage := true;
 
FColor := clWindow;
 
FFont := TFont.Create;
 
FReplaceDialog := repDefault;
 
FLanguage := wdEnglishUS;
 
 
// Don't create an ole server at design time
 
if not (csDesigning in ComponentState) then
 
begin
   
try
     
MsWordApp := CreateOleObject('Word.Application');
     
FActive := true;
     
MsWordApp.Documents.Add;
   
except
      on E
: Exception do
     
begin
       
// MessageDlg('Cannot Connect to MS Word',mtError,[mbOk],0);
       
// Activate above if visual failure required
       
FActive := false;
     
end;
   
end;
 
end;
end;
 
destructor
TSpellCheck.Destroy;
begin
 
FFont.Free;
 
 
if FActive and not (csDesigning in ComponentState) then
 
begin
   
MsWordApp.Quit;
   
MsWordApp := VarNull;
 
end;
 
  inherited
Destroy;
end;
 
// ======================================
// Property Get/Set methods
// ======================================
 
procedure
TSpellCheck.SetFFont(NewValue: TFont);
begin
 
FFont.Assign(NewValue);
end;
 
// ===========================================
// Return a list of synonyms for single word
// ===========================================
 
function TSpellCheck.GetSynonyms(StrWord: string;
 
Synonyms: TStrings): boolean;
var
 
SynInfo: OleVariant;
  i
, j: integer;
  TS
: OleVariant;
 
Retvar: boolean;
begin
 
Synonyms.Clear;
 
 
if FActive then
 
begin
   
SynInfo := MsWordApp.SynonymInfo[StrWord,
     
LanguageArray[ord(FLanguage)]];
   
for i := 1 to SynInfo.MeaningCount do
   
begin
      TS
:= SynInfo.SynonymList[i];
     
for j := VarArrayLowBound(TS, 1) to VarArrayHighBound(TS, 1) do
       
Synonyms.Add(TS[j]);
   
end;
 
   
RetVar := SynInfo.Found;
 
end
 
else
   
RetVar := false;
 
 
Result := RetVar;
end;
 
// =======================================
// Check the spelling of a single word
// Suggestions returned in TStrings
// =======================================
 
function TSpellCheck.CheckWordSpelling(StrWord: string;
 
Suggestions: TStrings): boolean;
var
 
Retvar: boolean;
  i
: integer;
begin
 
RetVar := false;
 
if Suggestions <> nil then
   
Suggestions.Clear;
 
 
if FActive then
 
begin
   
if MsWordApp.CheckSpelling(StrWord) then
     
RetVar := true
   
else
   
begin
     
if Suggestions <> nil then
     
begin
       
MsSuggestions := MsWordApp.GetSpellingSuggestions(StrWord);
       
for i := 1 to MsSuggestions.Count do
         
Suggestions.Add(MsSuggestions.Item(i));
       
MsSuggestions := VarNull;
     
end;
   
end;
 
end;
 
 
Result := RetVar;
end;
 
// ======================================================
// Check the spelling text of a string with option to
// Replace words. Correct string returned in var StrText
// ======================================================
 
procedure
TSpellCheck.CheckTextSpelling(var StrText: string);
var
 
StartPos, CurPos,
   
WordsChanged: integer;
 
ChkWord, UserWord: string;
 
EoTxt: boolean;
 
  procedure
GetNextWordStart;
 
begin
   
ChkWord := '';
   
while (StartPos <= length(StrText)) and
     
(not (StrText[StartPos] in FLetterChars)) do
      inc
(StartPos);
   
CurPos := StartPos;
 
end;
 
begin
 
if FActive and (length(StrText) > 0) then
 
begin
   
MakeForm;
   
StartPos := 1;
   
EoTxt := false;
   
WordsChanged := 0;
   
GetNextWordStart;
 
   
while not EoTxt do
   
begin
     
// Is it a letter ?
     
if StrText[CurPos] in FLetterChars then
     
begin
       
ChkWord := ChkWord + StrText[CurPos];
        inc
(CurPos);
     
end
     
else
     
begin
       
// Word end found - check spelling
       
if not CheckWordSpelling(ChkWord, FLbox.Items) then
       
begin
         
if Assigned(FBeforeCorrection) then
           
FBeforeCorrection(self, ChkWord, FLbox.Items);
 
         
// Default replacement dialog
         
if FReplaceDialog = repDefault then
         
begin
           
FEbox.Text := ChkWord;
           
FForm.ShowModal;
 
           
if FForm.ModalResult = mrOk then
           
begin
             
// Change mispelt word
             
Delete(StrText, StartPos, length(ChkWord));
             
Insert(FEbox.Text, StrText, StartPos);
             
CurPos := StartPos + length(FEbox.Text);
 
             
if ChkWord <> FEbox.Text then
             
begin
                inc
(WordsChanged);
               
if Assigned(FAfterCorrection) then
                 
FAfterCorrection(self, ChkWord, FEbox.Text);
             
end;
           
end
         
end
         
else
         
begin
           
// User defined replacemnt routine
           
UserWord := ChkWord;
           
if Assigned(FOnCorrection) then
             
FOnCorrection(self, UserWord);
           
Delete(StrText, StartPos, length(ChkWord));
           
Insert(UserWord, StrText, StartPos);
           
CurPos := StartPos + length(UserWord);
 
           
if ChkWord <> UserWord then
           
begin
              inc
(WordsChanged);
             
if Assigned(FAfterCorrection) then
               
FAfterCorrection(self, ChkWord, UserWord);
           
end;
         
end;
       
end;
 
       
StartPos := CurPos;
       
GetNextWordStart;
       
EoTxt := (StartPos > length(StrText));
     
end;
   
end;
 
   
CloseForm;
   
if FCompletedMessage then
     
MessageDlg('Spell Check Complete' + #13#10 +
       
IntToStr(WordsChanged) + ' words changed',
        mtInformation
, [mbOk], 0);
 
end
 
else if not FActive then
   
MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
 
else if FCompletedMessage then
   
MessageDlg('Spell Check Complete' + #13#10 +
     
'0 words changed', mtInformation, [mbOk], 0);
end;
 
// =============================================================
// Check the spelling of RichText with option to
// Replace words (in situ replacement direct to RichEdit.Text)
// =============================================================
 
procedure
TSpellCheck.CheckRichTextSpelling(RichEdit: TRichEdit);
var
 
StartPos, CurPos,
   
WordsChanged: integer;
 
StrText, ChkWord, UserWord: string;
 
SaveHide,
   
EoTxt: boolean;
 
  procedure
GetNextWordStart;
 
begin
   
ChkWord := '';
   
while (not (StrText[StartPos] in FLetterChars)) and
     
(StartPos <= length(StrText)) do
      inc
(StartPos);
   
CurPos := StartPos;
 
end;
 
begin
 
SaveHide := RichEdit.HideSelection;
 
RichEdit.HideSelection := false;
 
StrText := RichEdit.Text;
 
if FActive and (length(StrText) > 0) then
 
begin
   
MakeForm;
   
StartPos := 1;
   
EoTxt := false;
   
WordsChanged := 0;
   
GetNextWordStart;
 
   
while not EoTxt do
   
begin
     
// Is it a letter ?
     
if StrText[CurPos] in FLetterChars then
     
begin
       
ChkWord := ChkWord + StrText[CurPos];
        inc
(CurPos);
     
end
     
else
     
begin
       
// Word end found - check spelling
       
if not CheckWordSpelling(ChkWord, FLbox.Items) then
       
begin
         
if Assigned(FBeforeCorrection) then
           
FBeforeCorrection(self, ChkWord, FLbox.Items);
 
         
// Default replacement dialog
         
if FReplaceDialog = repDefault then
         
begin
           
FEbox.Text := ChkWord;
           
RichEdit.SelStart := StartPos - 1;
           
RichEdit.SelLength := length(ChkWord);
           
FForm.ShowModal;
 
           
if FForm.ModalResult = mrOk then
           
begin
             
// Change mispelt word
             
Delete(StrText, StartPos, length(ChkWord));
             
Insert(FEbox.Text, StrText, StartPos);
             
CurPos := StartPos + length(FEbox.Text);
             
RichEdit.SelText := FEbox.Text;
 
             
if ChkWord <> FEbox.Text then
             
begin
                inc
(WordsChanged);
               
if Assigned(FAfterCorrection) then
                 
FAfterCorrection(self, ChkWord, FEbox.Text);
             
end;
           
end
         
end
         
else
         
begin
           
// User defined replacemnt routine
           
UserWord := ChkWord;
           
RichEdit.SelStart := StartPos - 1;
           
RichEdit.SelLength := length(ChkWord);
           
if Assigned(FOnCorrection) then
             
FOnCorrection(self, UserWord);
           
Delete(StrText, StartPos, length(ChkWord));
           
Insert(UserWord, StrText, StartPos);
           
CurPos := StartPos + length(UserWord);
           
RichEdit.SelText := UserWord;
 
           
if ChkWord <> UserWord then
           
begin
              inc
(WordsChanged);
             
if Assigned(FAfterCorrection) then
               
FAfterCorrection(self, ChkWord, UserWord);
           
end;
         
end;
       
end;
 
       
StartPos := CurPos;
       
GetNextWordStart;
       
EoTxt := (StartPos > length(StrText));
     
end;
   
end;
 
   
CloseForm;
   
RichEdit.HideSelection := SaveHide;
   
if FCompletedMessage then
     
MessageDlg('Spell Check Complete' + #13#10 +
       
IntToStr(WordsChanged) + ' words changed',
        mtInformation
, [mbOk], 0);
 
end
 
else if not FActive then
   
MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
 
else if FCompletedMessage then
   
MessageDlg('Spell Check Complete' + #13#10 +
     
'0 words changed', mtInformation, [mbOk], 0);
end;
 
// =============================================================
// Check the spelling of Memo with option to
// Replace words (in situ replacement direct to Memo.Text)
// =============================================================
 
procedure
TSpellCheck.CheckMemoTextSpelling(Memo: TMemo);
var
 
StartPos, CurPos,
   
WordsChanged: integer;
 
StrText, ChkWord, UserWord: string;
 
SaveHide,
   
EoTxt: boolean;
 
  procedure
GetNextWordStart;
 
begin
   
ChkWord := '';
   
while (not (StrText[StartPos] in FLetterChars)) and
     
(StartPos <= length(StrText)) do
      inc
(StartPos);
   
CurPos := StartPos;
 
end;
 
begin
 
SaveHide := Memo.HideSelection;
 
Memo.HideSelection := false;
 
StrText := Memo.Text;
 
if FActive and (length(StrText) > 0) then
 
begin
   
MakeForm;
   
StartPos := 1;
   
EoTxt := false;
   
WordsChanged := 0;
   
GetNextWordStart;
 
   
while not EoTxt do
   
begin
     
// Is it a letter ?
     
if StrText[CurPos] in FLetterChars then
     
begin
       
ChkWord := ChkWord + StrText[CurPos];
        inc
(CurPos);
     
end
     
else
     
begin
       
// Word end found - check spelling
       
if not CheckWordSpelling(ChkWord, FLbox.Items) then
       
begin
         
if Assigned(FBeforeCorrection) then
           
FBeforeCorrection(self, ChkWord, FLbox.Items);
 
         
// Default replacement dialog
         
if FReplaceDialog = repDefault then
         
begin
           
FEbox.Text := ChkWord;
           
Memo.SelStart := StartPos - 1;
           
Memo.SelLength := length(ChkWord);
           
FForm.ShowModal;
 
           
if FForm.ModalResult = mrOk then
           
begin
             
// Change mispelt word
             
Delete(StrText, StartPos, length(ChkWord));
             
Insert(FEbox.Text, StrText, StartPos);
             
CurPos := StartPos + length(FEbox.Text);
             
Memo.SelText := FEbox.Text;
 
             
if ChkWord <> FEbox.Text then
             
begin
                inc
(WordsChanged);
               
if Assigned(FAfterCorrection) then
                 
FAfterCorrection(self, ChkWord, FEbox.Text);
             
end;
           
end
         
end
         
else
         
begin
           
// User defined replacemnt routine
           
UserWord := ChkWord;
           
Memo.SelStart := StartPos - 1;
           
Memo.SelLength := length(ChkWord);
           
if Assigned(FOnCorrection) then
             
FOnCorrection(self, UserWord);
           
Delete(StrText, StartPos, length(ChkWord));
           
Insert(UserWord, StrText, StartPos);
           
CurPos := StartPos + length(UserWord);
           
Memo.SelText := UserWord;
 
           
if ChkWord <> UserWord then
           
begin
              inc
(WordsChanged);
             
if Assigned(FAfterCorrection) then
               
FAfterCorrection(self, ChkWord, UserWord);
           
end;
         
end;
       
end;
 
       
StartPos := CurPos;
       
GetNextWordStart;
       
EoTxt := (StartPos > length(StrText));
     
end;
   
end;
 
   
Memo.HideSelection := SaveHide;
   
CloseForm;
   
if FCompletedMessage then
     
MessageDlg('Spell Check Complete' + #13#10 +
       
IntToStr(WordsChanged) + ' words changed',
        mtInformation
, [mbOk], 0);
 
end
 
else if not FActive then
   
MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
 
else if FCompletedMessage then
   
MessageDlg('Spell Check Complete' + #13#10 +
     
'0 words changed', mtInformation, [mbOk], 0);
end;
 
// ======================================================================
// Return a list of Anagrams - Careful, long words generate HUGE lists
// ======================================================================
 
procedure
TSpellCheck.Anagrams(const InString: string; StringList: TStrings);
var
 
WordsChecked, WordsFound: integer;
 
  procedure
RecursePerm(const StrA, StrB: string; Len: integer; SL: TStrings);
 
var
    i
: integer;
    A
, B: string;
 
begin
   
if (length(StrA) = Len) then
   
begin
      inc
(WordsChecked);
     
if (SL.IndexOf(StrA) = -1) and MsWordApp.CheckSpelling(StrA) then
     
begin
        inc
(WordsFound);
        SL
.Add(StrA);
       
Application.ProcessMessages;
     
end;
   
end;
 
   
for i := 1 to length(StrB) do
   
begin
      A
:= StrB;
      B
:= StrA + A[i];
     
delete(A, i, 1);
     
RecursePerm(B, A, Len, SL);
   
end;
 
end;
 
begin
 
if FActive then
 
begin
   
WordsChecked := 0;
   
WordsFound := 0;
   
StringList.Clear;
   
Application.ProcessMessages;
   
RecursePerm('', LowerCase(InString), length(InString), StringList);
   
if FCompletedMessage then
     
MessageDlg('Anagram Search Check Complete' + #13#10 +
       
IntToStr(WordsChecked) + ' words checked' + #13#10 +
       
IntToStr(WordsFound) + ' anagrams found',
        mtInformation
, [mbOk], 0);
 
end
 
else
   
MessageDlg('Spell Check not Active', mtError, [mbOk], 0);
end;
 
// =========================================
// Create default replacement form
// =========================================
 
procedure
TSpellCheck.MakeForm;
begin
 
// Correction form container
 
FForm := TForm.Create(nil);
 
FForm.Position := poScreenCenter;
 
FForm.BorderStyle := bsDialog;
 
FForm.Height := 260; // 240 if no caption
 
FForm.Width := 210;
 
 
// Remove form's caption if desired
 
//  SetWindowLong(FForm.Handle,GWL_STYLE,
 
//                GetWindowLong(FForm.Handle,GWL_STYLE) AND NOT WS_CAPTION);
 
 
FForm.ClientHeight := FForm.Height;
 
 
// Edit box of offending word
 
FEbox := TEdit.Create(FForm);
 
FEbox.Parent := FForm;
 
FEbox.Top := 8;
 
FEbox.Left := 8;
 
FEbox.Width := 185;
 
FEBox.Font := FFont;
 
FEbox.Color := FColor;
 
 
// Suggestion list box
 
FLbox := TListBox.Create(FForm);
 
FLbox.Parent := FForm;
 
FLbox.Top := 32;
 
FLbox.Left := 8;
 
FLbox.Width := 185;
 
FLbox.Height := 193;
 
FLbox.Color := FColor;
 
FLbox.Font := FFont;
 
FLbox.OnClick := SuggestedClick;
 
FLbox.OnDblClick := SuggestedClick;
 
 
// Cancel Button
 
FCancelBtn := TBitBtn.Create(FForm);
 
FCancelBtn.Parent := FForm;
 
FCancelBtn.Top := 232;
 
FCancelBtn.Left := 8;
 
FCancelBtn.Kind := bkCancel;
 
FCancelBtn.Caption := 'Ignore';
 
 
// Change Button
 
FChangeBtn := TBitBtn.Create(FForm);
 
FChangeBtn.Parent := FForm;
 
FChangeBtn.Top := 232;
 
FChangeBtn.Left := 120;
 
FChangeBtn.Kind := bkOk;
 
FChangeBtn.Caption := 'Change';
end;
 
// =============================================
// Close the correction form and free memory
// =============================================
 
procedure
TSpellCheck.CloseForm;
begin
 
FChangeBtn.Free;
 
FCancelBtn.Free;
 
FLbox.Free;
 
FEbox.Free;
 
FForm.Free;
end;
 
// ====================================================
// FLbox on click event to populate the edit box
// with selected suggestion (OnClick/OnDblClick)
// ====================================================
 
procedure
TSpellCheck.SuggestedClick(Sender: TObject);
begin
 
FEbox.Text := FLbox.Items[FLbox.ItemIndex];
end;
 
end.

Взято с Delphi Knowledge Base: https://www.baltsoft.com/