Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
VCL MS Word Spell Check and Thesaurus Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
22-Oct-02
Category
OLE
Language
Delphi 5.x
Views
132
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Mike Heydon

VCL MS Word Spell Check and Thesaurus

Answer:

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. 


1   unit SpellChk;
2   interface
3   
4   // =============================================================================
5   // MS Word COM Interface to Spell Check and Synonyms
6   // Mike Heydon Dec 2000
7   // mheydon@pgbison.co.za
8   // =============================================================================
9   
10  uses Windows, SysUtils, Classes, ComObj, Dialogs, Forms, StdCtrls,
11    Controls, Buttons, Graphics, ComCtrls, Variants;
12  
13  // Above uses Variants is for Delphi 6 - remove for Delphi 5 and less
14  
15  type
16    // Event definitions
17    TSpellCheckBeforeCorrection = procedure(Sender: TObject;
18      MispeltWord: string;
19      Suggestions: TStrings) of object;
20  
21    TSpellCheckAfterCorrection = procedure(Sender: TObject;
22      MispeltWord: string;
23      CorrectedWord: string) of object;
24  
25    TSpellCheckOnCorrection = procedure(Sender: TObject;
26      var WordToCorrect: string) of object;
27  
28    // Property types
29    TSpellCheckReplacement = (repDefault, repUser);
30    TSpellCheckLetters = set of char;
31  
32    TSpellCheckLanguage = (wdLanguageNone, wdNoProofing, wdDanish, wdGerman,
33      wdSwissGerman, wdEnglishAUS, wdEnglishUK, wdEnglishUS,
34      wdEnglishCanadian, wdEnglishNewZealand,
35      wdEnglishSouthAfrica, wdSpanish, wdFrench,
36      wdFrenchCanadian, wdItalian, wdDutch, wdNorwegianBokmol,
37      wdNorwegianNynorsk, wdBrazilianPortuguese,
38      wdPortuguese, wdFinnish, wdSwedish, wdCatalan, wdGreek,
39      wdTurkish, wdRussian, wdCzech, wdHungarian, wdPolish,
40      wdSlovenian, wdBasque, wdMalaysian, wdJapanese, wdKorean,
41      wdSimplifiedChinese, wdTraditionalChinese,
42      wdSwissFrench, wdSesotho, wdTsonga, wdTswana, wdVenda,
43      wdXhosa, wdZulu, wdAfrikaans, wdArabic, wdHebrew,
44      wdSlovak, wdFarsi, wdRomanian, wdCroatian, wdUkrainian,
45      wdByelorussian, wdEstonian, wdLatvian, wdMacedonian,
46      wdSerbianLatin, wdSerbianCyrillic, wdIcelandic,
47      wdBelgianFrench, wdBelgianDutch, wdBulgarian,
48      wdMexicanSpanish, wdSpanishModernSort, wdSwissItalian);
49  
50    // Main TSpellcheck Class
51    TSpellCheck = class(TComponent)
52    private
53      MsWordApp,
54        MsSuggestions: OleVariant;
55      FLetterChars: TSpellCheckLetters;
56      FFont: TFont;
57      FColor: TColor;
58      FReplaceDialog: TSpellCheckReplacement;
59      FCompletedMessage,
60        FActive: boolean;
61      FLanguage: TSpellCheckLanguage;
62      FForm: TForm;
63      FEbox: TEdit;
64      FLbox: TListBox;
65      FCancelBtn,
66        FChangeBtn: TBitBtn;
67      FBeforeCorrection: TSpellCheckBeforeCorrection;
68      FAfterCorrection: TSpellCheckAfterCorrection;
69      FOnCorrection: TSpellCheckOnCorrection;
70      procedure SetFFont(NewValue: TFont);
71    protected
72      procedure MakeForm;
73      procedure CloseForm;
74      procedure SuggestedClick(Sender: TObject);
75    public
76      constructor Create(AOwner: TComponent); override;
77      destructor Destroy; override;
78      function GetSynonyms(StrWord: string; Synonyms: TStrings): boolean;
79      function CheckWordSpelling(StrWord: string;
80        Suggestions: TStrings): boolean;
81      procedure CheckTextSpelling(var StrText: string);
82      procedure CheckRichTextSpelling(RichEdit: TRichEdit);
83      procedure CheckMemoTextSpelling(Memo: TMemo);
84      procedure Anagrams(const InString: string; StringList: TStrings);
85      property Active: boolean read FActive;
86      property LetterChars: TSpellCheckletters read FLetterChars write FLetterChars;
87    published
88      property Language: TSpellCheckLanguage read FLanguage
89        write FLanguage;
90      property CompletedMessage: boolean read FCompletedMessage
91        write FCompletedMessage;
92      property Color: TColor read FColor write FColor;
93      property Font: TFont read FFont write SetFFont;
94      property BeforeCorrection: TSpellCheckBeforeCorrection
95        read FBeforeCorrection
96        write FBeforeCorrection;
97      property AfterCorrection: TSpellCheckAfterCorrection
98        read FAfterCorrection
99        write FAfterCorrection;
100     property OnCorrection: TSpellCheckOnCorrection
101       read FOnCorrection
102       write FOnCorrection;
103     property ReplaceDialog: TSpellCheckReplacement
104       read FReplaceDialog
105       write FReplaceDialog;
106   end;
107 
108 procedure register;
109 
110 // -----------------------------------------------------------------------------
111 implementation
112 
113 // Mapped Hex values for ord(FLanguage)
114 const
115 
116   LanguageArray: array[0..63] of integer =
117   ($0, $400, $406, $407, $807, $C09, $809, $409,
118     $1009, $1409, $1C09, $40A, $40C, $C0C, $410,
119     $413, $414, $814, $416, $816, $40B, $41D, $403,
120     $408, $41F, $419, $405, $40E, $415, $424, $42D,
121     $43E, $411, $412, $804, $404, $100C, $430, $431,
122     $432, $433, $434, $435, $436, $401, $40D, $41B,
123     $429, $418, $41A, $422, $423, $425, $426, $42F,
124     $81A, $C1A, $40F, $80C, $813, $402, $80A, $C0A, $810);
125 
126   // Change to Component Pallete of choice
127 
128 procedure register;
129 begin
130   RegisterComponents('MahExtra', [TSpellCheck]);
131 end;
132 
133 // TSpellCheck
134 
135 constructor TSpellCheck.Create(AOwner: TComponent);
136 begin
137   inherited Create(AOwner);
138   // Defaults
139   FLetterChars := ['A'..'Z', 'a'..'z'];
140   FCompletedMessage := true;
141   FColor := clWindow;
142   FFont := TFont.Create;
143   FReplaceDialog := repDefault;
144   FLanguage := wdEnglishUS;
145 
146   // Don't create an ole server at design time
147   if not (csDesigning in ComponentState) then
148   begin
149     try
150       MsWordApp := CreateOleObject('Word.Application');
151       FActive := true;
152       MsWordApp.Documents.Add;
153     except
154       on E: Exception do
155       begin
156         // MessageDlg('Cannot Connect to MS Word',mtError,[mbOk],0);
157         // Activate above if visual failure required
158         FActive := false;
159       end;
160     end;
161   end;
162 end;
163 
164 destructor TSpellCheck.Destroy;
165 begin
166   FFont.Free;
167 
168   if FActive and not (csDesigning in ComponentState) then
169   begin
170     MsWordApp.Quit;
171     MsWordApp := VarNull;
172   end;
173 
174   inherited Destroy;
175 end;
176 
177 // ======================================
178 // Property Get/Set methods
179 // ======================================
180 
181 procedure TSpellCheck.SetFFont(NewValue: TFont);
182 begin
183   FFont.Assign(NewValue);
184 end;
185 
186 // ===========================================
187 // Return a list of synonyms for single word
188 // ===========================================
189 
190 function TSpellCheck.GetSynonyms(StrWord: string;
191   Synonyms: TStrings): boolean;
192 var
193   SynInfo: OleVariant;
194   i, j: integer;
195   TS: OleVariant;
196   Retvar: boolean;
197 begin
198   Synonyms.Clear;
199 
200   if FActive then
201   begin
202     SynInfo := MsWordApp.SynonymInfo[StrWord,
203       LanguageArray[ord(FLanguage)]];
204     for i := 1 to SynInfo.MeaningCount do
205     begin
206       TS := SynInfo.SynonymList[i];
207       for j := VarArrayLowBound(TS, 1) to VarArrayHighBound(TS, 1) do
208         Synonyms.Add(TS[j]);
209     end;
210 
211     RetVar := SynInfo.Found;
212   end
213   else
214     RetVar := false;
215 
216   Result := RetVar;
217 end;
218 
219 // =======================================
220 // Check the spelling of a single word
221 // Suggestions returned in TStrings
222 // =======================================
223 
224 function TSpellCheck.CheckWordSpelling(StrWord: string;
225   Suggestions: TStrings): boolean;
226 var
227   Retvar: boolean;
228   i: integer;
229 begin
230   RetVar := false;
231   if Suggestions <> nil then
232     Suggestions.Clear;
233 
234   if FActive then
235   begin
236     if MsWordApp.CheckSpelling(StrWord) then
237       RetVar := true
238     else
239     begin
240       if Suggestions <> nil then
241       begin
242         MsSuggestions := MsWordApp.GetSpellingSuggestions(StrWord);
243         for i := 1 to MsSuggestions.Count do
244           Suggestions.Add(MsSuggestions.Item(i));
245         MsSuggestions := VarNull;
246       end;
247     end;
248   end;
249 
250   Result := RetVar;
251 end;
252 
253 // ======================================================
254 // Check the spelling text of a string with option to
255 // Replace words. Correct string returned in var StrText
256 // ======================================================
257 
258 procedure TSpellCheck.CheckTextSpelling(var StrText: string);
259 var
260   StartPos, CurPos,
261     WordsChanged: integer;
262   ChkWord, UserWord: string;
263   EoTxt: boolean;
264 
265   procedure GetNextWordStart;
266   begin
267     ChkWord := '';
268     while (StartPos <= length(StrText)) and
269       (not (StrText[StartPos] in FLetterChars)) do
270       inc(StartPos);
271     CurPos := StartPos;
272   end;
273 
274 begin
275   if FActive and (length(StrText) > 0) then
276   begin
277     MakeForm;
278     StartPos := 1;
279     EoTxt := false;
280     WordsChanged := 0;
281     GetNextWordStart;
282 
283     while not EoTxt do
284     begin
285       // Is it a letter ?
286       if StrText[CurPos] in FLetterChars then
287       begin
288         ChkWord := ChkWord + StrText[CurPos];
289         inc(CurPos);
290       end
291       else
292       begin
293         // Word end found - check spelling
294         if not CheckWordSpelling(ChkWord, FLbox.Items) then
295         begin
296           if Assigned(FBeforeCorrection) then
297             FBeforeCorrection(self, ChkWord, FLbox.Items);
298 
299           // Default replacement dialog
300           if FReplaceDialog = repDefault then
301           begin
302             FEbox.Text := ChkWord;
303             FForm.ShowModal;
304 
305             if FForm.ModalResult = mrOk then
306             begin
307               // Change mispelt word
308               Delete(StrText, StartPos, length(ChkWord));
309               Insert(FEbox.Text, StrText, StartPos);
310               CurPos := StartPos + length(FEbox.Text);
311 
312               if ChkWord <> FEbox.Text then
313               begin
314                 inc(WordsChanged);
315                 if Assigned(FAfterCorrection) then
316                   FAfterCorrection(self, ChkWord, FEbox.Text);
317               end;
318             end
319           end
320           else
321           begin
322             // User defined replacemnt routine
323             UserWord := ChkWord;
324             if Assigned(FOnCorrection) then
325               FOnCorrection(self, UserWord);
326             Delete(StrText, StartPos, length(ChkWord));
327             Insert(UserWord, StrText, StartPos);
328             CurPos := StartPos + length(UserWord);
329 
330             if ChkWord <> UserWord then
331             begin
332               inc(WordsChanged);
333               if Assigned(FAfterCorrection) then
334                 FAfterCorrection(self, ChkWord, UserWord);
335             end;
336           end;
337         end;
338 
339         StartPos := CurPos;
340         GetNextWordStart;
341         EoTxt := (StartPos > length(StrText));
342       end;
343     end;
344 
345     CloseForm;
346     if FCompletedMessage then
347       MessageDlg('Spell Check Complete' + #13#10 +
348         IntToStr(WordsChanged) + ' words changed',
349         mtInformation, [mbOk], 0);
350   end
351   else if not FActive then
352     MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
353   else if FCompletedMessage then
354     MessageDlg('Spell Check Complete' + #13#10 +
355       '0 words changed', mtInformation, [mbOk], 0);
356 end;
357 
358 // =============================================================
359 // Check the spelling of RichText with option to
360 // Replace words (in situ replacement direct to RichEdit.Text)
361 // =============================================================
362 
363 procedure TSpellCheck.CheckRichTextSpelling(RichEdit: TRichEdit);
364 var
365   StartPos, CurPos,
366     WordsChanged: integer;
367   StrText, ChkWord, UserWord: string;
368   SaveHide,
369     EoTxt: boolean;
370 
371   procedure GetNextWordStart;
372   begin
373     ChkWord := '';
374     while (not (StrText[StartPos] in FLetterChars)) and
375       (StartPos <= length(StrText)) do
376       inc(StartPos);
377     CurPos := StartPos;
378   end;
379 
380 begin
381   SaveHide := RichEdit.HideSelection;
382   RichEdit.HideSelection := false;
383   StrText := RichEdit.Text;
384   if FActive and (length(StrText) > 0) then
385   begin
386     MakeForm;
387     StartPos := 1;
388     EoTxt := false;
389     WordsChanged := 0;
390     GetNextWordStart;
391 
392     while not EoTxt do
393     begin
394       // Is it a letter ?
395       if StrText[CurPos] in FLetterChars then
396       begin
397         ChkWord := ChkWord + StrText[CurPos];
398         inc(CurPos);
399       end
400       else
401       begin
402         // Word end found - check spelling
403         if not CheckWordSpelling(ChkWord, FLbox.Items) then
404         begin
405           if Assigned(FBeforeCorrection) then
406             FBeforeCorrection(self, ChkWord, FLbox.Items);
407 
408           // Default replacement dialog
409           if FReplaceDialog = repDefault then
410           begin
411             FEbox.Text := ChkWord;
412             RichEdit.SelStart := StartPos - 1;
413             RichEdit.SelLength := length(ChkWord);
414             FForm.ShowModal;
415 
416             if FForm.ModalResult = mrOk then
417             begin
418               // Change mispelt word
419               Delete(StrText, StartPos, length(ChkWord));
420               Insert(FEbox.Text, StrText, StartPos);
421               CurPos := StartPos + length(FEbox.Text);
422               RichEdit.SelText := FEbox.Text;
423 
424               if ChkWord <> FEbox.Text then
425               begin
426                 inc(WordsChanged);
427                 if Assigned(FAfterCorrection) then
428                   FAfterCorrection(self, ChkWord, FEbox.Text);
429               end;
430             end
431           end
432           else
433           begin
434             // User defined replacemnt routine
435             UserWord := ChkWord;
436             RichEdit.SelStart := StartPos - 1;
437             RichEdit.SelLength := length(ChkWord);
438             if Assigned(FOnCorrection) then
439               FOnCorrection(self, UserWord);
440             Delete(StrText, StartPos, length(ChkWord));
441             Insert(UserWord, StrText, StartPos);
442             CurPos := StartPos + length(UserWord);
443             RichEdit.SelText := UserWord;
444 
445             if ChkWord <> UserWord then
446             begin
447               inc(WordsChanged);
448               if Assigned(FAfterCorrection) then
449                 FAfterCorrection(self, ChkWord, UserWord);
450             end;
451           end;
452         end;
453 
454         StartPos := CurPos;
455         GetNextWordStart;
456         EoTxt := (StartPos > length(StrText));
457       end;
458     end;
459 
460     CloseForm;
461     RichEdit.HideSelection := SaveHide;
462     if FCompletedMessage then
463       MessageDlg('Spell Check Complete' + #13#10 +
464         IntToStr(WordsChanged) + ' words changed',
465         mtInformation, [mbOk], 0);
466   end
467   else if not FActive then
468     MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
469   else if FCompletedMessage then
470     MessageDlg('Spell Check Complete' + #13#10 +
471       '0 words changed', mtInformation, [mbOk], 0);
472 end;
473 
474 // =============================================================
475 // Check the spelling of Memo with option to
476 // Replace words (in situ replacement direct to Memo.Text)
477 // =============================================================
478 
479 procedure TSpellCheck.CheckMemoTextSpelling(Memo: TMemo);
480 var
481   StartPos, CurPos,
482     WordsChanged: integer;
483   StrText, ChkWord, UserWord: string;
484   SaveHide,
485     EoTxt: boolean;
486 
487   procedure GetNextWordStart;
488   begin
489     ChkWord := '';
490     while (not (StrText[StartPos] in FLetterChars)) and
491       (StartPos <= length(StrText)) do
492       inc(StartPos);
493     CurPos := StartPos;
494   end;
495 
496 begin
497   SaveHide := Memo.HideSelection;
498   Memo.HideSelection := false;
499   StrText := Memo.Text;
500   if FActive and (length(StrText) > 0) then
501   begin
502     MakeForm;
503     StartPos := 1;
504     EoTxt := false;
505     WordsChanged := 0;
506     GetNextWordStart;
507 
508     while not EoTxt do
509     begin
510       // Is it a letter ?
511       if StrText[CurPos] in FLetterChars then
512       begin
513         ChkWord := ChkWord + StrText[CurPos];
514         inc(CurPos);
515       end
516       else
517       begin
518         // Word end found - check spelling
519         if not CheckWordSpelling(ChkWord, FLbox.Items) then
520         begin
521           if Assigned(FBeforeCorrection) then
522             FBeforeCorrection(self, ChkWord, FLbox.Items);
523 
524           // Default replacement dialog
525           if FReplaceDialog = repDefault then
526           begin
527             FEbox.Text := ChkWord;
528             Memo.SelStart := StartPos - 1;
529             Memo.SelLength := length(ChkWord);
530             FForm.ShowModal;
531 
532             if FForm.ModalResult = mrOk then
533             begin
534               // Change mispelt word
535               Delete(StrText, StartPos, length(ChkWord));
536               Insert(FEbox.Text, StrText, StartPos);
537               CurPos := StartPos + length(FEbox.Text);
538               Memo.SelText := FEbox.Text;
539 
540               if ChkWord <> FEbox.Text then
541               begin
542                 inc(WordsChanged);
543                 if Assigned(FAfterCorrection) then
544                   FAfterCorrection(self, ChkWord, FEbox.Text);
545               end;
546             end
547           end
548           else
549           begin
550             // User defined replacemnt routine
551             UserWord := ChkWord;
552             Memo.SelStart := StartPos - 1;
553             Memo.SelLength := length(ChkWord);
554             if Assigned(FOnCorrection) then
555               FOnCorrection(self, UserWord);
556             Delete(StrText, StartPos, length(ChkWord));
557             Insert(UserWord, StrText, StartPos);
558             CurPos := StartPos + length(UserWord);
559             Memo.SelText := UserWord;
560 
561             if ChkWord <> UserWord then
562             begin
563               inc(WordsChanged);
564               if Assigned(FAfterCorrection) then
565                 FAfterCorrection(self, ChkWord, UserWord);
566             end;
567           end;
568         end;
569 
570         StartPos := CurPos;
571         GetNextWordStart;
572         EoTxt := (StartPos > length(StrText));
573       end;
574     end;
575 
576     Memo.HideSelection := SaveHide;
577     CloseForm;
578     if FCompletedMessage then
579       MessageDlg('Spell Check Complete' + #13#10 +
580         IntToStr(WordsChanged) + ' words changed',
581         mtInformation, [mbOk], 0);
582   end
583   else if not FActive then
584     MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
585   else if FCompletedMessage then
586     MessageDlg('Spell Check Complete' + #13#10 +
587       '0 words changed', mtInformation, [mbOk], 0);
588 end;
589 
590 // ======================================================================
591 // Return a list of Anagrams - Careful, long words generate HUGE lists
592 // ======================================================================
593 
594 procedure TSpellCheck.Anagrams(const InString: string; StringList: TStrings);
595 var
596   WordsChecked, WordsFound: integer;
597 
598   procedure RecursePerm(const StrA, StrB: string; Len: integer; SL: TStrings);
599   var
600     i: integer;
601     A, B: string;
602   begin
603     if (length(StrA) = Len) then
604     begin
605       inc(WordsChecked);
606       if (SL.IndexOf(StrA) = -1) and MsWordApp.CheckSpelling(StrA) then
607       begin
608         inc(WordsFound);
609         SL.Add(StrA);
610         Application.ProcessMessages;
611       end;
612     end;
613 
614     for i := 1 to length(StrB) do
615     begin
616       A := StrB;
617       B := StrA + A[i];
618       delete(A, i, 1);
619       RecursePerm(B, A, Len, SL);
620     end;
621   end;
622 
623 begin
624   if FActive then
625   begin
626     WordsChecked := 0;
627     WordsFound := 0;
628     StringList.Clear;
629     Application.ProcessMessages;
630     RecursePerm('', LowerCase(InString), length(InString), StringList);
631     if FCompletedMessage then
632       MessageDlg('Anagram Search Check Complete' + #13#10 +
633         IntToStr(WordsChecked) + ' words checked' + #13#10 +
634         IntToStr(WordsFound) + ' anagrams found',
635         mtInformation, [mbOk], 0);
636   end
637   else
638     MessageDlg('Spell Check not Active', mtError, [mbOk], 0);
639 end;
640 
641 // =========================================
642 // Create default replacement form
643 // =========================================
644 
645 procedure TSpellCheck.MakeForm;
646 begin
647   // Correction form container
648   FForm := TForm.Create(nil);
649   FForm.Position := poScreenCenter;
650   FForm.BorderStyle := bsDialog;
651   FForm.Height := 260; // 240 if no caption
652   FForm.Width := 210;
653 
654   // Remove form's caption if desired
655   //  SetWindowLong(FForm.Handle,GWL_STYLE,
656   //                GetWindowLong(FForm.Handle,GWL_STYLE) AND NOT WS_CAPTION);
657 
658   FForm.ClientHeight := FForm.Height;
659 
660   // Edit box of offending word
661   FEbox := TEdit.Create(FForm);
662   FEbox.Parent := FForm;
663   FEbox.Top := 8;
664   FEbox.Left := 8;
665   FEbox.Width := 185;
666   FEBox.Font := FFont;
667   FEbox.Color := FColor;
668 
669   // Suggestion list box
670   FLbox := TListBox.Create(FForm);
671   FLbox.Parent := FForm;
672   FLbox.Top := 32;
673   FLbox.Left := 8;
674   FLbox.Width := 185;
675   FLbox.Height := 193;
676   FLbox.Color := FColor;
677   FLbox.Font := FFont;
678   FLbox.OnClick := SuggestedClick;
679   FLbox.OnDblClick := SuggestedClick;
680 
681   // Cancel Button
682   FCancelBtn := TBitBtn.Create(FForm);
683   FCancelBtn.Parent := FForm;
684   FCancelBtn.Top := 232;
685   FCancelBtn.Left := 8;
686   FCancelBtn.Kind := bkCancel;
687   FCancelBtn.Caption := 'Ignore';
688 
689   // Change Button
690   FChangeBtn := TBitBtn.Create(FForm);
691   FChangeBtn.Parent := FForm;
692   FChangeBtn.Top := 232;
693   FChangeBtn.Left := 120;
694   FChangeBtn.Kind := bkOk;
695   FChangeBtn.Caption := 'Change';
696 end;
697 
698 // =============================================
699 // Close the correction form and free memory
700 // =============================================
701 
702 procedure TSpellCheck.CloseForm;
703 begin
704   FChangeBtn.Free;
705   FCancelBtn.Free;
706   FLbox.Free;
707   FEbox.Free;
708   FForm.Free;
709 end;
710 
711 // ====================================================
712 // FLbox on click event to populate the edit box
713 // with selected suggestion (OnClick/OnDblClick)
714 // ====================================================
715 
716 procedure TSpellCheck.SuggestedClick(Sender: TObject);
717 begin
718   FEbox.Text := FLbox.Items[FLbox.ItemIndex];
719 end;
720 
721 end.


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC