source: cprs/branches/HealthSevak-CPRS/CPRS-Chart/uSpell.pas@ 1722

Last change on this file since 1722 was 1705, checked in by healthsevak, 9 years ago

updated this file to version 28,
did minor changes for making it compatible with MS Office 10
and Implemented the OpenSource based spell check feature
File size: 36.0 KB
Line 
1unit uSpell;
2// Word settings need to be restored to origional settings!
3{$O-}
4
5{$DEFINE CPRS}
6{$UNDEF CPRS}
7
8interface
9
10uses
11 Windows, Messages, SysUtils, Classes, Controls, Forms, ComObj, StdCtrls, ComCtrls,
12 rCore, ORFn, Word2000, Office_TLB, Variants, clipbrd, ActiveX, Contnrs, PSAPI, ExtCtrls;
13
14type
15 TSpellCheckAvailable = record
16 Evaluated: boolean;
17 Available: boolean;
18 end;
19
20function SpellCheckInProgress: Boolean;
21procedure KillSpellCheck;
22function SpellCheckAvailable: Boolean;
23procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; added 2nd parameter}
24procedure GrammarCheckForControl(AnEditControl: TCustomMemo);
25
26// Do Not Call these routines - internal use only
27procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo);
28procedure RefocusSpellCheckWindow;
29
30const
31 SpellCheckerSettingName = 'SpellCheckerSettings';
32//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ;
33{moved following from implementation section to this place to make them visible outside unit too}
34 TX_NO_SPELL_CHECK = 'Spell checking is unavailable.';
35 TX_NO_GRAMMAR_CHECK = 'Grammar checking is unavailable.';
36 TX_SPELL_COMPLETE = 'The spelling check is complete.';
37 TX_GRAMMAR_COMPLETE = 'The grammar check is complete.';
38 TX_SPELL_ABORT = 'The spelling check terminated abnormally.';
39 TX_GRAMMAR_ABORT = 'The grammar check terminated abnormally.';
40 TX_SPELL_CANCELLED = 'Spelling check was cancelled before completion.';
41 TX_GRAMMAR_CANCELLED = 'Grammar check was cancelled before completion.';
42
43 TX_NO_CORRECTIONS = 'Corrections have NOT been applied.';
44 TX_NO_DETAILS = 'No further details are available.';
45 CRLF = #13#10;
46
47var
48 SpellCheckerSettings: string = '';
49
50
51implementation
52
53uses VAUtils, fSpellNotify, uInit, fHunSpell;
54
55const
56 TX_ERROR_TITLE = 'Error';
57 TX_ERROR_INTRO = 'An error has occured.';
58 TX_TRY_AGAIN = 'Would you like to try again?';
59 TX_WINDOW_TITLE = 'CPRS-Chart Spell Checking #';
60 { TX_NO_SPELL_CHECK = 'Spell checking is unavailable.';
61{ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ;}
62{moved following from implementation section to this place to make them visible outside unit too}
63//begin comment @ska
64{ TX_NO_GRAMMAR_CHECK = 'Grammar checking is unavailable.';
65 TX_SPELL_COMPLETE = 'The spelling check is complete.';
66 TX_GRAMMAR_COMPLETE = 'The grammar check is complete.';
67 TX_SPELL_ABORT = 'The spelling check terminated abnormally.';
68 TX_GRAMMAR_ABORT = 'The grammar check terminated abnormally.';
69 TX_SPELL_CANCELLED = 'Spelling check was cancelled before completion.';
70 TX_GRAMMAR_CANCELLED = 'Grammar check was cancelled before completion.';
71 TX_NO_DETAILS = 'No further details are available.';
72 TX_NO_CORRECTIONS = 'Corrections have NOT been applied.';
73 CRLF = #13#10;}
74 //end comment @ska
75
76// TABOO_STARTING_CHARS = '!"#$%&()*+,./:;<=>?@[\]^_`{|}';
77 VALID_STARTING_CHARS = '''-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
78
79type
80 TMSWordThread = class(TThread)
81 private
82 FBeforeLines: TStringList;
83 FAfterLines: TStringList;
84 FWordSettings: TList;
85 FWordVersion: single;{To support Office 2010 & above ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; added new variable;}
86 FEditControl: TCustomMemo;
87 FShowingMessage: boolean;
88// FEmptyVar: OleVariant;
89 FFalseVar: OleVariant;
90// FTrueVar: OleVariant;
91 FNullStr: OleVariant;
92 FWord: WordApplication;
93 FDoc: WordDocument;
94 FDialog: OleVariant;
95 FDocDlg: OleVariant;
96 FText: string;
97 FSpellCheck: boolean;
98 FSucceeded: boolean;
99 FCanceled: boolean;
100 FTitle: string;
101 FDocWindowHandle: HWnd;
102 FOldFormChange: TNotifyEvent;
103 FOldOnActivate: TNotifyEvent;
104 FError: Exception;
105 FErrorText1: string;
106 FErrorText2: string;
107 FAllowErrorRetry: boolean;
108 FRetryResult: TShow508MessageResult;
109 FResultMessage: string;
110 FSpellChecking: boolean;
111 FLock: TRTLCriticalSection;
112 procedure OnFormChange(Sender: TObject);
113 procedure OnAppActivate(Sender: TObject);
114 procedure OnThreadTerminate(Sender: TObject);
115 procedure FindDocumentWindow;
116 procedure TransferText;
117 function RunWithErrorTrap(AMethod: TThreadMethod;
118 SpellCheckErrorMessage, GrammarCheckErrorMessage, AdditionalErrorMessage: string;
119 AllowRetry: boolean): boolean;
120 procedure WordError;
121 procedure StartWord;
122 procedure CreateDocument;
123 procedure DoCheck;
124 procedure ConfigWord;
125 procedure ConfigDoc;
126 procedure GetDialogs;
127 procedure SaveUserSettings;
128 procedure LoadUserSettings;
129 procedure ExitWord;
130 procedure ReportResults;
131 procedure SaveWordSettings;
132 procedure RestoreWordSettings;
133 function UserSetting(Index: integer): boolean;
134 procedure ThreadLock;
135 procedure ThreadUnlock;
136 protected
137 constructor CreateThread(SpellCheck: boolean; AEditControl: TCustomMemo);
138 procedure Execute; override;
139 public
140 procedure RefocusSpellCheckDialog;
141 property Text: string read FText;
142 property Succeeded: boolean read FSucceeded;
143 property Canceled: boolean read FCanceled;
144 end;
145
146var
147 MSWordThread: TMSWordThread = nil;
148
149function ControlHasText(SpellCheck: boolean; AnEditControl: TCustomMemo): boolean;
150var
151 i: integer;
152begin
153 Result := FALSE;
154 if not assigned(AnEditControl) then
155 ShowMsg('Spell Check programming error')
156 else
157 begin
158 for i := 0 to AnEditControl.Lines.Count - 1 do
159 begin
160 if trim(AnEditControl.Lines[i]) <> '' then
161 begin
162 Result := TRUE;
163 break;
164 end;
165 end;
166 if not Result then
167 begin
168 if SpellCheck then
169 ShowMsg(TX_SPELL_COMPLETE)
170 else
171 ShowMsg(TX_GRAMMAR_COMPLETE)
172 end;
173 end;
174end;
175
176function SpellCheckInProgress: boolean;
177begin
178 Result := assigned(MSWordThread);
179end;
180
181var
182 uSpellCheckAvailable: TSpellCheckAvailable;
183
184procedure KillSpellCheck;
185var
186 checking: boolean;
187 WordHandle: HWnd;
188 ProcessID: DWORD;
189 ProcessHandle: THandle;
190
191begin
192 if assigned(MSWordThread) then
193 begin
194 with MSWordThread do
195 begin
196 ThreadLock;
197 try
198 checking := FSpellChecking;
199 WordHandle := FDocWindowHandle;
200 Terminate;
201 finally
202 ThreadUnlock;
203 end;
204 try
205 if checking then
206 begin
207 GetWindowThreadProcessId(WordHandle, ProcessID);
208 ProcessHandle := OpenProcess(PROCESS_TERMINATE, False, ProcessID);
209 try
210 TerminateProcess(ProcessHandle, 0);
211 finally
212 CloseHandle(ProcessHandle);
213 end;
214 end;
215 if assigned(MSWordThread) then
216 begin
217 WaitFor;
218 end;
219 except
220 end;
221 end;
222 end;
223end;
224
225
226{ Spell Checking using Visual Basic for Applications script }
227
228function SpellCheckAvailable: Boolean;
229//const
230// WORD_VBA_CLSID = 'CLSID\{000209FF-0000-0000-C000-000000000046}';
231begin
232// CHANGED FOR PT. SAFETY ISSUE RELEASE 19.16, PATCH OR*3*155 - ADDED NEXT 2 LINES:
233 //result := false;
234 //exit;
235// Reenabled in version 21.1, via parameter setting (RV)
236// Result := (GetUserParam('ORWOR SPELL CHECK ENABLED?') = '1');
237 with uSpellCheckAvailable do // only want to call this once per session!!! v23.10+
238 begin
239 if not Evaluated then
240 begin
241 Available := (GetUserParam('ORWOR SPELL CHECK ENABLED?') = '1');
242 Evaluated := True;
243 end;
244 Result := Available;
245 end;
246end;
247
248{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine, added new proc}
249procedure DoHanSpellCheck(anEditControl: TCustomMemo);
250//Initiates OpenSource (HunSpell) based Spell check
251begin
252 SuspendTimeout;
253 try
254{being a class function, we don't have to create an object instance beforehand}
255 TfrmHunSpell.DoHunSpellCheck(AnEditControl);
256 finally
257 ResumeTimeout;
258 end;
259end;
260
261procedure DoSpellCheck(SpellCheck: boolean; AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Added second parameter}
262var
263 frmSpellNotify: TfrmSpellNotify;
264begin
265{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; commented out net line}
266//if assigned(MSWordThread) then exit; {commented out this line and instead added additional check for OpenSource in next line}
267 if (assigned(MSWordThread) and not OpenSource) then exit;
268
269 if ControlHasText(SpellCheck, AnEditControl) then
270{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine}
271//Begin @ska ; added next three new lines
272 if OpenSource and SpellCheck then
273 DoHanSpellCheck(AnEditControl)
274 else
275//end @ska; 01 May 2015
276 begin
277 frmSpellNotify := TfrmSpellNotify.Create(Application);
278 try
279 SuspendTimeout;
280 try
281 frmSpellNotify.SpellCheck := SpellCheck;
282 frmSpellNotify.EditControl := AnEditControl;
283 frmSpellNotify.ShowModal;
284 finally
285 ResumeTimeout;
286 end;
287 finally
288 frmSpellNotify.Free;
289 end;
290 end;
291end;
292
293procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo);
294begin
295 MSWordThread := TMSWordThread.CreateThread(SpellCheck, EditControl);
296 while assigned(MSWordThread) do
297 begin
298 Application.ProcessMessages;
299 sleep(50);
300 end;
301end;
302
303procedure RefocusSpellCheckWindow;
304begin
305 if assigned(MSWordThread) then
306 MSWordThread.RefocusSpellCheckDialog;
307end;
308
309procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter}
310begin
311 DoSpellCheck(True, AnEditControl, OpenSource); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter}
312end;
313
314procedure GrammarCheckForControl(AnEditControl: TCustomMemo);
315begin
316 DoSpellCheck(False, AnEditControl);
317end;
318{ TMSWordThread }
319
320const
321 RETRY_MAX = 3;
322
323 usCheckSpellingAsYouType = 1;
324 usCheckGrammarAsYouType = 2;
325 usIgnoreInternetAndFileAddresses = 3;
326 usIgnoreMixedDigits = 4;
327 usIgnoreUppercase = 5;
328 usCheckGrammarWithSpelling = 6;
329 usShowReadabilityStatistics = 7;
330 usSuggestFromMainDictionaryOnly = 8;
331 usSuggestSpellingCorrections = 9;
332 usHideSpellingErrors = 10;
333 usHideGrammarErrors = 11;
334
335 sTrueCode = 'T';
336 sFalseCode = 'F';
337
338 // AFAYT = AutoFormatAsYouType
339 wsAFAYTApplyBorders = 0;
340 wsAFAYTApplyBulletedLists = 1;
341 wsAFAYTApplyFirstIndents = 2;
342 wsAFAYTApplyHeadings = 3;
343 wsAFAYTApplyNumberedLists = 4;
344 wsAFAYTApplyTables = 5;
345 wsAFAYTAutoLetterWizard = 6;
346 wsAFAYTDefineStyles = 7;
347 wsAFAYTFormatListItemBeginning = 8;
348 wsAFAYTInsertClosings = 9;
349 wsAFAYTReplaceQuotes = 10;
350 wsAFAYTReplaceFractions = 11;
351 wsAFAYTReplaceHyperlinks = 12;
352 wsAFAYTReplaceOrdinals = 13;
353 wsAFAYTReplacePlainTextEmphasis = 14;
354 wsAFAYTReplaceSymbols = 15;
355 wsAutoFormatReplaceQuotes = 16;
356 wsTabIndentKey = 17;
357 wsWindowState = 18;
358 wsSaveInterval = 19;
359 wsTrackRevisions = 20;
360 wsShowRevisions = 21;
361 wsShowSummary = 22; {not used for Word 2010; ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter }
362
363procedure TMSWordThread.Execute;
364var
365 ok: boolean;
366
367 procedure EnableAppActivation;
368 begin
369 FWord.Caption := FTitle;
370 Synchronize(FindDocumentWindow);
371 end;
372
373 procedure Run(AMethod: TThreadMethod; force: boolean = false);
374 begin
375 if terminated then exit;
376 if ok or force then
377 begin
378 ok := RunWithErrorTrap(AMethod, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE);
379 end;
380 end;
381
382 procedure BuildResultMessage;
383 begin
384 FResultMessage := '';
385 if FCanceled or (not FSucceeded) then
386 begin
387 if FSpellCheck then
388 FResultMessage := TX_SPELL_CANCELLED
389 else
390 FResultMessage := TX_GRAMMAR_CANCELLED;
391 FResultMessage := FResultMessage + CRLF + TX_NO_CORRECTIONS;
392 end
393 else
394 if FSucceeded then
395 begin
396 if FSpellCheck then
397 FResultMessage := TX_SPELL_COMPLETE
398 else
399 FResultMessage := TX_GRAMMAR_COMPLETE;
400 end;
401 end;
402
403 procedure SetStatus(value, force: boolean);
404 begin
405 if ok or force then
406 begin
407 ThreadLock;
408 FSpellChecking := value;
409 ThreadUnlock;
410 end;
411 end;
412
413begin
414 CoInitialize(nil);
415 ok := true;
416 try
417 if RunWithErrorTrap(StartWord, TX_NO_SPELL_CHECK, TX_NO_GRAMMAR_CHECK, TX_TRY_AGAIN, TRUE) then
418 begin
419 try
420 if RunWithErrorTrap(CreateDocument, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE) then
421 begin
422 try
423 EnableAppActivation;
424 Run(SaveWordSettings);
425 Run(ConfigWord);
426 Run(ConfigDoc);
427 Run(GetDialogs);
428 Run(LoadUserSettings);
429 SetStatus(True, False);
430 Run(DoCheck);
431 SetStatus(False, True);
432 Run(SaveUserSettings);
433 Run(RestoreWordSettings);
434 Run(ExitWord, True);
435 if ok and (not terminated) then
436 begin
437 Synchronize(TransferText);
438 BuildResultMessage;
439 Synchronize(ReportResults);
440 end;
441 finally
442 FDoc := nil;
443 end;
444 end;
445 finally
446 FWord := nil;
447 end;
448 end;
449 finally
450 CoUninitialize;
451 end;
452end;
453
454procedure TMSWordThread.ExitWord;
455var
456 Save: OleVariant;
457 Doc: OleVariant;
458
459begin
460 VarClear(FDialog);
461 VarClear(FDocDlg);
462 VariantInit(Save);
463 VariantInit(Doc);
464 try
465 Save := wdDoNotSaveChanges;
466 Doc := wdWordDocument;
467 FWord.Quit(Save, Doc, FFalseVar);
468 finally
469 VarClear(Save);
470 VarClear(Doc);
471 end;
472end;
473
474var
475 WindowTitle: string;
476 WindowHandle: HWnd;
477
478function FindDocWindow(Handle: HWND; Info: Pointer): BOOL; stdcall;
479var
480 title: string;
481begin
482 title := GetWindowTitle(Handle);
483 if title = WindowTitle then
484 begin
485 WindowHandle := Handle;
486 Result := FALSE;
487 end
488 else
489 Result := True;
490end;
491
492procedure TMSWordThread.FindDocumentWindow;
493begin
494 WindowTitle := FTitle;
495 WindowHandle := 0;
496 EnumWindows(@FindDocWindow, 0);
497 FDocWindowHandle := WindowHandle;
498end;
499
500procedure TMSWordThread.GetDialogs;
501//var
502// DispParams: TDispParams;
503// OleArgs: array of OleVariant;
504// ExcepInfo: TExcepInfo;
505// Status: integer;
506begin
507// SetLength(OleArgs, 1);
508// VariantInit(OleArgs[0]);
509// try
510 VariantInit(FDialog);
511 FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar);
512 VariantInit(FDocDlg);
513 FDocDlg := FWord.ActiveDocument;
514(* OleArgs[0] := wdDialogToolsOptionsSpellingAndGrammar;
515 DispParams.rgvarg := @OleArgs[0];
516 DispParams.cArgs := 1;
517 DispParams.rgdispidNamedArgs := nil;
518 DispParams.cNamedArgs := 0;
519// FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar);
520 // dispid 0 is the Item method
521 Status := FWord.Dialogs.Invoke(0, GUID_NULL, LOCALE_USER_DEFAULT,
522 DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDialog, @ExcepInfo, nil);
523 if Status <> S_OK then
524 DispatchInvokeError(Status, ExcepInfo);
525 VariantInit(FDocDlg);
526 DispParams.rgvarg := nil;
527 DispParams.cArgs := 0;
528 Status := FWord.Invoke(3, GUID_NULL, LOCALE_USER_DEFAULT,
529 DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDocDlg, @ExcepInfo, nil);
530 if Status <> S_OK then
531 DispatchInvokeError(Status, ExcepInfo);
532 finally
533 VarClear(OleArgs[0]);
534 SetLength(OleArgs, 0);
535 end; *)
536end;
537
538procedure TMSWordThread.LoadUserSettings;
539begin
540 // load FUserSettings from server
541
542 // these are default values
543 (*
5449 AlwaysSuggest,
5458 SuggestFromMainDictOnly,
5465 IgnoreAllCaps,
5474 IgnoreMixedDigits,
548 ResetIgnoreAll,
549 Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6,
550 CustomDict7, CustomDict8, CustomDict9, CustomDict10,
5511 AutomaticSpellChecking,
5523 FilenamesEmailAliases,
553 UserDict1,
5542 AutomaticGrammarChecking,
5556?? ForegroundGrammar,
5567 ShowStatistics,
557 Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch,
55810 HideGrammarErrors,
559 CheckSpelling, GrLidUI, SpLidUI,
560 DictLang1, DictLang2, DictLang3,
561 DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10,
56211 HideSpellingErrors,
563 HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell,
564 AraSpeller, ProcessCompoundNoun
565 *)
566// FDialog.
567 ThreadLock;
568 try
569 FDialog.AutomaticSpellChecking := UserSetting(usCheckSpellingAsYouType);
570 FDialog.AutomaticGrammarChecking := UserSetting(usCheckGrammarAsYouType);
571 FDialog.FilenamesEmailAliases := UserSetting(usIgnoreInternetAndFileAddresses);
572 FDialog.IgnoreMixedDigits := UserSetting(usIgnoreMixedDigits);
573 FDialog.ForegroundGrammar := UserSetting(usCheckGrammarWithSpelling);
574 FDialog.ShowStatistics := UserSetting(usShowReadabilityStatistics);
575 FDialog.SuggestFromMainDictOnly := UserSetting(usSuggestFromMainDictionaryOnly);
576 FDialog.IgnoreAllCaps := UserSetting(usIgnoreUppercase);
577 FDialog.AlwaysSuggest := UserSetting(usSuggestSpellingCorrections);
578 FDialog.HideSpellingErrors := UserSetting(usHideSpellingErrors);
579 FDialog.HideGrammarErrors := UserSetting(usHideGrammarErrors);
580 FDialog.Execute;
581 finally
582 ThreadUnlock;
583 end;
584
585 // need list of custom dictionaries - default to CUSTOM.DIC (or query Word for it!!!)
586// FWord.CustomDictionaries
587
588end;
589
590procedure TMSWordThread.OnAppActivate(Sender: TObject);
591begin
592 if assigned(FOldOnActivate) then
593 FOldOnActivate(Sender);
594 RefocusSpellCheckDialog;
595end;
596
597procedure TMSWordThread.OnFormChange(Sender: TObject);
598begin
599 if assigned(FOldFormChange) then
600 FOldFormChange(Sender);
601 RefocusSpellCheckDialog;
602end;
603
604procedure TMSWordThread.OnThreadTerminate(Sender: TObject);
605begin
606 Application.OnActivate := FOldOnActivate;
607 Screen.OnActiveFormChange := FOldFormChange;
608// VarClear(FEmptyVar);
609 VarClear(FFalseVar);
610// VarClear(FTrueVar);
611 FWordSettings.Free;
612 FBeforeLines.Free;
613 FAfterLines.Free;
614 DeleteCriticalSection(FLock);
615 Screen.Cursor := crDefault;
616 MSWordThread := nil;
617end;
618
619procedure TMSWordThread.RefocusSpellCheckDialog;
620begin
621 Application.ProcessMessages;
622 if Application.Active and (not FShowingMessage) and (FDocWindowHandle <> 0) then
623 begin
624 SetForegroundWindow(FDocWindowHandle);
625 SetFocus(FDocWindowHandle);
626 end;
627end;
628
629procedure TMSWordThread.ReportResults;
630var
631 icon: TShow508MessageIcon;
632begin
633 if FSucceeded then
634 icon := smiInfo
635 else
636 icon := smiWarning;
637 FShowingMessage := True;
638 try
639 ShowMsg(FResultMessage, icon, smbOK);
640 finally
641 FShowingMessage := False;
642 end;
643end;
644
645procedure TMSWordThread.RestoreWordSettings;
646
647 function Load(Index: integer): integer;
648 begin
649 if FWordSettings.Count > Index then
650 Result := Integer(FWordSettings[Index])
651 else
652 Result := 0
653 end;
654
655begin
656 FWord.Options.AutoFormatAsYouTypeApplyBorders := boolean(Load(wsAFAYTApplyBorders));
657 FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := boolean(Load(wsAFAYTApplyBulletedLists));
658 FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := boolean(Load(wsAFAYTApplyFirstIndents));
659 FWord.Options.AutoFormatAsYouTypeApplyHeadings := boolean(Load(wsAFAYTApplyHeadings));
660 FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := boolean(Load(wsAFAYTApplyNumberedLists));
661 FWord.Options.AutoFormatAsYouTypeApplyTables := boolean(Load(wsAFAYTApplyTables));
662 FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := boolean(Load(wsAFAYTAutoLetterWizard));
663 FWord.Options.AutoFormatAsYouTypeDefineStyles := boolean(Load(wsAFAYTDefineStyles));
664 FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := boolean(Load(wsAFAYTFormatListItemBeginning));
665 FWord.Options.AutoFormatAsYouTypeInsertClosings := boolean(Load(wsAFAYTInsertClosings));
666 FWord.Options.AutoFormatAsYouTypeReplaceQuotes := boolean(Load(wsAFAYTReplaceQuotes));
667 FWord.Options.AutoFormatAsYouTypeReplaceFractions := boolean(Load(wsAFAYTReplaceFractions));
668 FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := boolean(Load(wsAFAYTReplaceHyperlinks));
669 FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := boolean(Load(wsAFAYTReplaceOrdinals));
670 FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := boolean(Load(wsAFAYTReplacePlainTextEmphasis));
671 FWord.Options.AutoFormatAsYouTypeReplaceSymbols := boolean(Load(wsAFAYTReplaceSymbols));
672 FWord.Options.AutoFormatReplaceQuotes := boolean(Load(wsAutoFormatReplaceQuotes));
673 FWord.Options.TabIndentKey := boolean(Load(wsTabIndentKey));
674 FWord.WindowState := Load(wsWindowState);
675 FWord.Options.SaveInterval := Load(wsSaveInterval);
676 FDoc.TrackRevisions := boolean(Load(wsTrackRevisions));
677 FDoc.ShowRevisions := boolean(Load(wsShowRevisions));
678 if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10} // altered for Word 2010
679 FDoc.ShowSummary := boolean(Load(wsShowSummary));
680end;
681
682function TMSWordThread.RunWithErrorTrap(AMethod: TThreadMethod;
683 SpellCheckErrorMessage, GrammarCheckErrorMessage,
684 AdditionalErrorMessage: string; AllowRetry: boolean): boolean;
685var
686 RetryCount: integer;
687 Done: boolean;
688begin
689 RetryCount := 0;
690 Result := TRUE;
691 repeat
692 Done := TRUE;
693 try
694 AMethod;
695 except
696 on E: Exception do
697 begin
698 if not terminated then
699 begin
700 inc(RetryCount);
701 Done := FALSE;
702 if RetryCount >= RETRY_MAX then
703 begin
704 FError := E;
705 FAllowErrorRetry := AllowRetry;
706 if FSpellCheck then
707 FErrorText1 := SpellCheckErrorMessage
708 else
709 FErrorText1 := GrammarCheckErrorMessage;
710 FErrorText2 := AdditionalErrorMessage;
711 Synchronize(WordError);
712 if AllowRetry and (FRetryResult = smrRetry) then
713 RetryCount := 0
714 else
715 begin
716 Result := FALSE;
717 Done := TRUE;
718 end;
719 end;
720 end;
721 end;
722 end;
723 until Done;
724end;
725
726procedure TMSWordThread.DoCheck;
727begin
728 FDoc.Content.Text := FText;
729 FDoc.Content.SpellingChecked := False;
730 FDoc.Content.GrammarChecked := False;
731 if FSpellCheck then
732 begin
733 FDocDlg.Content.CheckSpelling;
734// FDoc.CheckSpelling(FNullStr, FEmptyVar, FEmptyVar, {Ignore, Suggest, }FNullStr, FNullStr,
735// FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr);
736 FSucceeded := FDoc.Content.SpellingChecked;
737 FText := FDoc.Content.Text;
738 end
739 else
740 begin
741 FDoc.Content.CheckGrammar;
742 FSucceeded := FDoc.Content.GrammarChecked;
743 FText := FDoc.Content.Text;
744 end;
745 FCanceled := (FText = '');
746end;
747
748procedure TMSWordThread.SaveUserSettings;
749
750 procedure SaveSetting(Value: boolean; Index: integer);
751 begin
752 while length(SpellCheckerSettings) < Index do
753 SpellCheckerSettings := SpellCheckerSettings + ' ';
754 if Value then
755 SpellCheckerSettings[Index] := sTrueCode
756 else
757 SpellCheckerSettings[Index] := sFalseCode;
758 end;
759begin
760 ThreadLock;
761 try
762 SpellCheckerSettings := '';
763 FDialog.Update;
764 SaveSetting(FDialog.AutomaticSpellChecking, usCheckSpellingAsYouType);
765 SaveSetting(FDialog.AutomaticGrammarChecking, usCheckGrammarAsYouType);
766 SaveSetting(FDialog.FilenamesEmailAliases, usIgnoreInternetAndFileAddresses);
767 SaveSetting(FDialog.IgnoreMixedDigits, usIgnoreMixedDigits);
768 SaveSetting(FDialog.IgnoreAllCaps, usIgnoreUppercase);
769 SaveSetting(FDialog.ForegroundGrammar, usCheckGrammarWithSpelling);
770 SaveSetting(FDialog.ShowStatistics, usShowReadabilityStatistics);
771 SaveSetting(FDialog.SuggestFromMainDictOnly, usSuggestFromMainDictionaryOnly);
772 SaveSetting(FDialog.AlwaysSuggest, usSuggestSpellingCorrections);
773 SaveSetting(FDialog.HideSpellingErrors, usHideSpellingErrors);
774 SaveSetting(FDialog.HideGrammarErrors, usHideGrammarErrors);
775 finally
776 ThreadUnlock;
777 end;
778 (*
7799 AlwaysSuggest,
7808 SuggestFromMainDictOnly,
7815 IgnoreAllCaps,
7824 IgnoreMixedDigits,
783 ResetIgnoreAll,
784 Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6,
785 CustomDict7, CustomDict8, CustomDict9, CustomDict10,
7861 AutomaticSpellChecking,
7873 FilenamesEmailAliases,
788 UserDict1,
7892 AutomaticGrammarChecking,
7906?? ForegroundGrammar,
7917 ShowStatistics,
792 Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch,
79310 HideGrammarErrors,
794 CheckSpelling, GrLidUI, SpLidUI,
795 DictLang1, DictLang2, DictLang3,
796 DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10,
79711 HideSpellingErrors,
798 HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell,
799 AraSpeller, ProcessCompoundNoun
800 *)
801end;
802
803procedure TMSWordThread.SaveWordSettings;
804
805 procedure Save(Value, Index: integer);
806 begin
807 while FWordSettings.Count <= Index do
808 FWordSettings.Add(nil);
809 FWordSettings[Index] := Pointer(Value);
810 end;
811
812begin
813 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBorders) , wsAFAYTApplyBorders);
814 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBulletedLists) , wsAFAYTApplyBulletedLists);
815 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyFirstIndents) , wsAFAYTApplyFirstIndents);
816 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyHeadings) , wsAFAYTApplyHeadings);
817 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyNumberedLists) , wsAFAYTApplyNumberedLists);
818 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyTables) , wsAFAYTApplyTables);
819 Save(Ord(FWord.Options.AutoFormatAsYouTypeAutoLetterWizard) , wsAFAYTAutoLetterWizard);
820 Save(Ord(FWord.Options.AutoFormatAsYouTypeDefineStyles) , wsAFAYTDefineStyles);
821 Save(Ord(FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning) , wsAFAYTFormatListItemBeginning);
822 Save(Ord(FWord.Options.AutoFormatAsYouTypeInsertClosings) , wsAFAYTInsertClosings);
823 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceQuotes) , wsAFAYTReplaceQuotes);
824 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceFractions) , wsAFAYTReplaceFractions);
825 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks) , wsAFAYTReplaceHyperlinks);
826 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceOrdinals) , wsAFAYTReplaceOrdinals);
827 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis) , wsAFAYTReplacePlainTextEmphasis);
828 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceSymbols) , wsAFAYTReplaceSymbols);
829 Save(Ord(FWord.Options.AutoFormatReplaceQuotes) , wsAutoFormatReplaceQuotes);
830 Save(Ord(FWord.Options.TabIndentKey) , wsTabIndentKey);
831 Save(Ord(FWord.WindowState) , wsWindowState);
832 Save(Ord(FWord.Options.SaveInterval) , wsSaveInterval);
833 Save(Ord(FDoc.TrackRevisions) , wsTrackRevisions);
834 Save(Ord(FDoc.ShowRevisions) , wsShowRevisions);
835 if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10}
836 Save(Ord(FDoc.ShowSummary) , wsShowSummary);
837end;
838
839procedure TMSWordThread.StartWord;
840begin
841 FWord := CoWordApplication.Create;
842 FWordVersion := StrToFloatDef(FWord.Version, 0.0); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Get Office version for office10 specific calls}
843end;
844
845procedure TMSWordThread.ThreadLock;
846begin
847 EnterCriticalSection(FLock);
848end;
849
850procedure TMSWordThread.ThreadUnlock;
851begin
852 LeaveCriticalSection(FLock);
853end;
854
855procedure TMSWordThread.TransferText;
856var
857 i: integer;
858 Lines: TStringList;
859begin
860 if FSucceeded and (not FCanceled) then
861 begin
862 Lines := TStringList.Create;
863 try
864 Lines.Text := FText;
865 // For some unknown reason spell check adds garbage lines to text
866 while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do
867 Lines.Delete(Lines.Count-1);
868 for i := 0 to FBeforeLines.Count-1 do
869 Lines.Insert(i, FBeforeLines[i]);
870 for i := 0 to FAfterLines.Count-1 do
871 Lines.Add(FAfterLines[i]);
872 FastAssign(Lines, FEditControl.Lines);
873 finally
874 Lines.Free;
875 end;
876 end;
877end;
878
879function TMSWordThread.UserSetting(Index: integer): boolean;
880begin
881 if SpellCheckerSettings = '' then
882 begin
883 case Index of
884 usCheckSpellingAsYouType: Result := True;
885 usCheckGrammarAsYouType: Result := False;
886 usIgnoreInternetAndFileAddresses: Result := True;
887 usIgnoreMixedDigits: Result := True;
888 usIgnoreUppercase: Result := True;
889 usCheckGrammarWithSpelling: Result := False;
890 usShowReadabilityStatistics: Result := False;
891 usSuggestFromMainDictionaryOnly: Result := False;
892 usSuggestSpellingCorrections: Result := True;
893 usHideSpellingErrors: Result := False;
894 usHideGrammarErrors: Result := True;
895 else Result := False;
896 end;
897 end
898 else
899 Result := copy(SpellCheckerSettings,Index,1) = sTrueCode;
900end;
901
902procedure TMSWordThread.ConfigDoc;
903begin
904 FDoc.TrackRevisions := False;
905 FDoc.ShowRevisions := False;
906 if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10}
907 FDoc.ShowSummary := False;
908 FWord.Height := 1000;
909 FWord.Width := 1000;
910 FWord.Top := -2000;
911 FWord.Left := -2000;
912end;
913
914procedure TMSWordThread.ConfigWord;
915begin
916// save all old values to FWord, restore when done.
917 FWord.Options.AutoFormatAsYouTypeApplyBorders := False;
918 FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := False;
919 FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := False;
920 FWord.Options.AutoFormatAsYouTypeApplyHeadings := False;
921 FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := False;
922 FWord.Options.AutoFormatAsYouTypeApplyTables := False;
923 FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := False;
924 FWord.Options.AutoFormatAsYouTypeDefineStyles := False;
925 FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := False;
926 FWord.Options.AutoFormatAsYouTypeInsertClosings := False;
927 FWord.Options.AutoFormatAsYouTypeReplaceQuotes := False;
928 FWord.Options.AutoFormatAsYouTypeReplaceFractions := False;
929 FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := False;
930 FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := False;
931 FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := False;
932 FWord.Options.AutoFormatAsYouTypeReplaceSymbols := False;
933 FWord.Options.AutoFormatReplaceQuotes := False;
934 FWord.Options.TabIndentKey := False;
935 FWord.WindowState := wdWindowStateNormal;
936 FWord.Options.SaveInterval := 0;
937 FWord.ResetIgnoreAll;
938end;
939
940procedure TMSWordThread.CreateDocument;
941var
942 DocType: OleVariant;
943begin
944 VariantInit(DocType);
945 try
946 DocType := wdNewBlankDocument;
947 FDoc := FWord.Documents.Add(FNullStr, FFalseVar, DocType, FFalseVar);
948 {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Commented out following line as it would fail for office 10 and above and also not really required for previous versions}
949// FDoc.Activate;
950 finally
951 VarClear(DocType);
952 end;
953end;
954
955constructor TMSWordThread.CreateThread(SpellCheck: boolean; AEditControl: TCustomMemo);
956
957 function WordDocTitle: string;
958 var
959 Guid: TGUID;
960 begin
961 if ActiveX.Succeeded(CreateGUID(Guid)) then
962 Result := GUIDToString(Guid)
963 else
964 Result := '';
965 Result := TX_WINDOW_TITLE + IntToStr(Application.Handle) + '/' + Result;
966 end;
967
968 function BeforeLineInvalid(Line: string): boolean;
969 var
970 i: integer;
971 begin
972 Result := (trim(Line) = '');
973 if not Result then
974 begin
975 for I := 1 to length(Line) do
976 if pos(Line[i], VALID_STARTING_CHARS) > 0 then exit;
977 Result := True;
978 end;
979 end;
980
981 procedure GetTextFromComponent;
982 var
983 Lines: TStrings;
984 begin
985 Lines := TStringList.Create;
986 try
987 FastAssign(AEditControl.Lines, Lines);
988
989 while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do
990 begin
991 FAfterLines.Insert(0, Lines[Lines.Count-1]);
992 Lines.Delete(Lines.Count-1);
993 end;
994
995 while (Lines.Count > 0) and (BeforeLineInvalid(Lines[0])) do
996 begin
997 FBeforeLines.Add(Lines[0]);
998 Lines.Delete(0);
999 end;
1000
1001 FText := Lines.Text;
1002 finally
1003 Lines.Free;
1004 end;
1005 end;
1006
1007begin
1008 inherited Create(TRUE);
1009 Screen.Cursor := crHourGlass;
1010 InitializeCriticalSection(FLock);
1011 FBeforeLines := TStringList.Create;
1012 FAfterLines := TStringList.Create;
1013 FWordSettings := TList.Create;
1014 FSpellChecking := False;
1015 FEditControl := AEditControl;
1016// VariantInit(FEmptyVar);
1017 VariantInit(FFalseVar);
1018// VariantInit(FTrueVar);
1019 VariantInit(FNullStr);
1020// TVarData(FEmptyVar).VType := VT_EMPTY;
1021 TVarData(FFalseVar).VType := VT_BOOL;
1022// TVarData(FTrueVar).VType := VT_BOOL;
1023 TVarData(FNullStr).VType := VT_BSTR;
1024// FEmptyVar := 0;
1025 FFalseVar := 0;
1026// FTrueVar := -1;
1027 FNullStr := '';
1028 FDocWindowHandle := 0;
1029 FSpellCheck := SpellCheck;
1030
1031 GetTextFromComponent;
1032
1033 FSucceeded := FALSE;
1034 FCanceled := FALSE;
1035 FTitle := WordDocTitle;
1036 FreeOnTerminate := True;
1037 OnTerminate := OnThreadTerminate;
1038 FOldOnActivate := Application.OnActivate;
1039 Application.OnActivate := OnAppActivate;
1040 FOldFormChange := Screen.OnActiveFormChange;
1041 Screen.OnActiveFormChange := OnFormChange;
1042 Resume;
1043end;
1044
1045procedure TMSWordThread.WordError;
1046var
1047 btn: TShow508MessageButton;
1048 msg: string;
1049
1050 procedure Append(txt: string);
1051 begin
1052 if txt <> '' then
1053 msg := msg + CRLF + txt;
1054 end;
1055
1056begin
1057 if FAllowErrorRetry then
1058 btn := smbRetryCancel
1059 else
1060 btn := smbOK;
1061 msg := TX_ERROR_INTRO;
1062 Append(FErrorText1);
1063 if FError.Message <> '' then
1064 Append(FError.Message)
1065 else
1066 Append(TX_NO_DETAILS);
1067 Append(FErrorText2);
1068 FShowingMessage := True;
1069 try
1070 FRetryResult := ShowMsg(Msg, TX_ERROR_TITLE, smiError, btn);
1071 finally
1072 FShowingMessage := False;
1073 end;
1074end;
1075
1076initialization
1077
1078finalization
1079 KillSpellCheck;
1080
1081end.
Note: See TracBrowser for help on using the repository browser.