source: cprs/trunk/CPRS-Chart/uSpell.pas@ 1742

Last change on this file since 1742 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28
File size: 35.9 KB
RevLine 
[841]1unit uSpell;
[1679]2// Word settings need to be restored to origional settings!
[841]3{$O-}
4
[1679]5{$DEFINE CPRS}
6{$UNDEF CPRS}
7
[841]8interface
9
10uses
11 Windows, Messages, SysUtils, Classes, Controls, Forms, ComObj, StdCtrls, ComCtrls,
[1679]12 rCore, ORFn, Word2000, Office_TLB, Variants, clipbrd, ActiveX, Contnrs, PSAPI, ExtCtrls;
[841]13
14type
15 TSpellCheckAvailable = record
16 Evaluated: boolean;
17 Available: boolean;
18 end;
19
20function SpellCheckInProgress: Boolean;
21procedure KillSpellCheck;
[1679]22function SpellCheckAvailable: Boolean;
23procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; added 2nd parameter}
[841]24procedure GrammarCheckForControl(AnEditControl: TCustomMemo);
25
[1679]26// Do Not Call these routines - internal use only
27procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo);
28procedure RefocusSpellCheckWindow;
[841]29
30const
[1679]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}
[841]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.';
[1679]42
43 TX_NO_CORRECTIONS = 'Corrections have NOT been applied.';
[841]44 TX_NO_DETAILS = 'No further details are available.';
[1679]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.';
[841]72 TX_NO_CORRECTIONS = 'Corrections have NOT been applied.';
[1679]73 CRLF = #13#10;}
74 //end comment @ska
[841]75
[1679]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
[841]146var
[1679]147 MSWordThread: TMSWordThread = nil;
[841]148
[1679]149function ControlHasText(SpellCheck: boolean; AnEditControl: TCustomMemo): boolean;
150var
151 i: integer;
[841]152begin
[1679]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
[841]159 begin
[1679]160 if trim(AnEditControl.Lines[i]) <> '' then
161 begin
162 Result := TRUE;
163 break;
164 end;
[841]165 end;
[1679]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;
[841]174end;
175
[1679]176function SpellCheckInProgress: boolean;
[841]177begin
[1679]178 Result := assigned(MSWordThread);
[841]179end;
180
[1679]181var
182 uSpellCheckAvailable: TSpellCheckAvailable;
[841]183
[1679]184procedure KillSpellCheck;
[841]185var
[1679]186 checking: boolean;
187 WordHandle: HWnd;
188 ProcessID: DWORD;
189 ProcessHandle: THandle;
190
[841]191begin
[1679]192 if assigned(MSWordThread) then
[841]193 begin
[1679]194 with MSWordThread do
[841]195 begin
[1679]196 ThreadLock;
197 try
198 checking := FSpellChecking;
199 WordHandle := FDocWindowHandle;
200 Terminate;
201 finally
202 ThreadUnlock;
[841]203 end;
[1679]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;
[841]221 end;
222 end;
223end;
224
[1679]225
[841]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
[1679]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 fHunSpell.TfrmHunSpell.DoHunSpellCheck(AnEditControl);
255 finally
256 ResumeTimeout;
257 end;
258end;
259
260procedure DoSpellCheck(SpellCheck: boolean; AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Added second parameter}
[841]261var
[1679]262 frmSpellNotify: TfrmSpellNotify;
[841]263begin
[1679]264{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; commented out net line}
265//if assigned(MSWordThread) then exit; {commented out this line and instead added additional check for OpenSource in next line}
266 if (assigned(MSWordThread) and not OpenSource) then exit;
267
268 if ControlHasText(SpellCheck, AnEditControl) then
269{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine}
270//Begin @ska ; added next three new lines
271 if OpenSource and SpellCheck then
272 DoHanSpellCheck(AnEditControl)
273 else
274//end @ska; 01 May 2015
275 begin
276 frmSpellNotify := TfrmSpellNotify.Create(Application);
[841]277 try
[1679]278 SuspendTimeout;
[841]279 try
[1679]280 frmSpellNotify.SpellCheck := SpellCheck;
281 frmSpellNotify.EditControl := AnEditControl;
282 frmSpellNotify.ShowModal;
283 finally
284 ResumeTimeout;
[841]285 end;
[1679]286 finally
287 frmSpellNotify.Free;
288 end;
289 end;
290end;
[841]291
[1679]292procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo);
293begin
294 MSWordThread := TMSWordThread.CreateThread(SpellCheck, EditControl);
295 while assigned(MSWordThread) do
296 begin
297 Application.ProcessMessages;
298 sleep(50);
299 end;
300end;
301
302procedure RefocusSpellCheckWindow;
303begin
304 if assigned(MSWordThread) then
305 MSWordThread.RefocusSpellCheckDialog;
306end;
307
308procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter}
309begin
310 DoSpellCheck(True, AnEditControl, OpenSource); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter}
311end;
312
313procedure GrammarCheckForControl(AnEditControl: TCustomMemo);
314begin
315 DoSpellCheck(False, AnEditControl);
316end;
317{ TMSWordThread }
318
319const
320 RETRY_MAX = 3;
321
322 usCheckSpellingAsYouType = 1;
323 usCheckGrammarAsYouType = 2;
324 usIgnoreInternetAndFileAddresses = 3;
325 usIgnoreMixedDigits = 4;
326 usIgnoreUppercase = 5;
327 usCheckGrammarWithSpelling = 6;
328 usShowReadabilityStatistics = 7;
329 usSuggestFromMainDictionaryOnly = 8;
330 usSuggestSpellingCorrections = 9;
331 usHideSpellingErrors = 10;
332 usHideGrammarErrors = 11;
333
334 sTrueCode = 'T';
335 sFalseCode = 'F';
336
337 // AFAYT = AutoFormatAsYouType
338 wsAFAYTApplyBorders = 0;
339 wsAFAYTApplyBulletedLists = 1;
340 wsAFAYTApplyFirstIndents = 2;
341 wsAFAYTApplyHeadings = 3;
342 wsAFAYTApplyNumberedLists = 4;
343 wsAFAYTApplyTables = 5;
344 wsAFAYTAutoLetterWizard = 6;
345 wsAFAYTDefineStyles = 7;
346 wsAFAYTFormatListItemBeginning = 8;
347 wsAFAYTInsertClosings = 9;
348 wsAFAYTReplaceQuotes = 10;
349 wsAFAYTReplaceFractions = 11;
350 wsAFAYTReplaceHyperlinks = 12;
351 wsAFAYTReplaceOrdinals = 13;
352 wsAFAYTReplacePlainTextEmphasis = 14;
353 wsAFAYTReplaceSymbols = 15;
354 wsAutoFormatReplaceQuotes = 16;
355 wsTabIndentKey = 17;
356 wsWindowState = 18;
357 wsSaveInterval = 19;
358 wsTrackRevisions = 20;
359 wsShowRevisions = 21;
360 wsShowSummary = 22; {not used for Word 2010; ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter }
361
362procedure TMSWordThread.Execute;
363var
364 ok: boolean;
365
366 procedure EnableAppActivation;
367 begin
368 FWord.Caption := FTitle;
369 Synchronize(FindDocumentWindow);
370 end;
371
372 procedure Run(AMethod: TThreadMethod; force: boolean = false);
373 begin
374 if terminated then exit;
375 if ok or force then
376 begin
377 ok := RunWithErrorTrap(AMethod, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE);
378 end;
379 end;
380
381 procedure BuildResultMessage;
382 begin
383 FResultMessage := '';
384 if FCanceled or (not FSucceeded) then
385 begin
386 if FSpellCheck then
387 FResultMessage := TX_SPELL_CANCELLED
388 else
389 FResultMessage := TX_GRAMMAR_CANCELLED;
390 FResultMessage := FResultMessage + CRLF + TX_NO_CORRECTIONS;
391 end
392 else
393 if FSucceeded then
394 begin
395 if FSpellCheck then
396 FResultMessage := TX_SPELL_COMPLETE
397 else
398 FResultMessage := TX_GRAMMAR_COMPLETE;
399 end;
400 end;
401
402 procedure SetStatus(value, force: boolean);
403 begin
404 if ok or force then
405 begin
406 ThreadLock;
407 FSpellChecking := value;
408 ThreadUnlock;
409 end;
410 end;
411
412begin
413 CoInitialize(nil);
414 ok := true;
415 try
416 if RunWithErrorTrap(StartWord, TX_NO_SPELL_CHECK, TX_NO_GRAMMAR_CHECK, TX_TRY_AGAIN, TRUE) then
417 begin
[841]418 try
[1679]419 if RunWithErrorTrap(CreateDocument, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE) then
420 begin
421 try
422 EnableAppActivation;
423 Run(SaveWordSettings);
424 Run(ConfigWord);
425 Run(ConfigDoc);
426 Run(GetDialogs);
427 Run(LoadUserSettings);
428 SetStatus(True, False);
429 Run(DoCheck);
430 SetStatus(False, True);
431 Run(SaveUserSettings);
432 Run(RestoreWordSettings);
433 Run(ExitWord, True);
434 if ok and (not terminated) then
[841]435 begin
[1679]436 Synchronize(TransferText);
437 BuildResultMessage;
438 Synchronize(ReportResults);
[841]439 end;
[1679]440 finally
441 FDoc := nil;
442 end;
[841]443 end;
444 finally
[1679]445 FWord := nil;
[841]446 end;
447 end;
[1679]448 finally
449 CoUninitialize;
[841]450 end;
[1679]451end;
[841]452
[1679]453procedure TMSWordThread.ExitWord;
454var
455 Save: OleVariant;
456 Doc: OleVariant;
457
458begin
459 VarClear(FDialog);
460 VarClear(FDocDlg);
461 VariantInit(Save);
462 VariantInit(Doc);
463 try
464 Save := wdDoNotSaveChanges;
465 Doc := wdWordDocument;
466 FWord.Quit(Save, Doc, FFalseVar);
467 finally
468 VarClear(Save);
469 VarClear(Doc);
470 end;
471end;
472
473var
474 WindowTitle: string;
475 WindowHandle: HWnd;
476
477function FindDocWindow(Handle: HWND; Info: Pointer): BOOL; stdcall;
478var
479 title: string;
480begin
481 title := GetWindowTitle(Handle);
482 if title = WindowTitle then
483 begin
484 WindowHandle := Handle;
485 Result := FALSE;
486 end
487 else
488 Result := True;
489end;
490
491procedure TMSWordThread.FindDocumentWindow;
492begin
493 WindowTitle := FTitle;
494 WindowHandle := 0;
495 EnumWindows(@FindDocWindow, 0);
496 FDocWindowHandle := WindowHandle;
497end;
498
499procedure TMSWordThread.GetDialogs;
500//var
501// DispParams: TDispParams;
502// OleArgs: array of OleVariant;
503// ExcepInfo: TExcepInfo;
504// Status: integer;
505begin
506// SetLength(OleArgs, 1);
507// VariantInit(OleArgs[0]);
508// try
509 VariantInit(FDialog);
510 FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar);
511 VariantInit(FDocDlg);
512 FDocDlg := FWord.ActiveDocument;
513(* OleArgs[0] := wdDialogToolsOptionsSpellingAndGrammar;
514 DispParams.rgvarg := @OleArgs[0];
515 DispParams.cArgs := 1;
516 DispParams.rgdispidNamedArgs := nil;
517 DispParams.cNamedArgs := 0;
518// FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar);
519 // dispid 0 is the Item method
520 Status := FWord.Dialogs.Invoke(0, GUID_NULL, LOCALE_USER_DEFAULT,
521 DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDialog, @ExcepInfo, nil);
522 if Status <> S_OK then
523 DispatchInvokeError(Status, ExcepInfo);
524 VariantInit(FDocDlg);
525 DispParams.rgvarg := nil;
526 DispParams.cArgs := 0;
527 Status := FWord.Invoke(3, GUID_NULL, LOCALE_USER_DEFAULT,
528 DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDocDlg, @ExcepInfo, nil);
529 if Status <> S_OK then
530 DispatchInvokeError(Status, ExcepInfo);
531 finally
532 VarClear(OleArgs[0]);
533 SetLength(OleArgs, 0);
534 end; *)
535end;
536
537procedure TMSWordThread.LoadUserSettings;
538begin
539 // load FUserSettings from server
540
541 // these are default values
542 (*
5439 AlwaysSuggest,
5448 SuggestFromMainDictOnly,
5455 IgnoreAllCaps,
5464 IgnoreMixedDigits,
547 ResetIgnoreAll,
548 Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6,
549 CustomDict7, CustomDict8, CustomDict9, CustomDict10,
5501 AutomaticSpellChecking,
5513 FilenamesEmailAliases,
552 UserDict1,
5532 AutomaticGrammarChecking,
5546?? ForegroundGrammar,
5557 ShowStatistics,
556 Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch,
55710 HideGrammarErrors,
558 CheckSpelling, GrLidUI, SpLidUI,
559 DictLang1, DictLang2, DictLang3,
560 DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10,
56111 HideSpellingErrors,
562 HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell,
563 AraSpeller, ProcessCompoundNoun
564 *)
565// FDialog.
566 ThreadLock;
567 try
568 FDialog.AutomaticSpellChecking := UserSetting(usCheckSpellingAsYouType);
569 FDialog.AutomaticGrammarChecking := UserSetting(usCheckGrammarAsYouType);
570 FDialog.FilenamesEmailAliases := UserSetting(usIgnoreInternetAndFileAddresses);
571 FDialog.IgnoreMixedDigits := UserSetting(usIgnoreMixedDigits);
572 FDialog.ForegroundGrammar := UserSetting(usCheckGrammarWithSpelling);
573 FDialog.ShowStatistics := UserSetting(usShowReadabilityStatistics);
574 FDialog.SuggestFromMainDictOnly := UserSetting(usSuggestFromMainDictionaryOnly);
575 FDialog.IgnoreAllCaps := UserSetting(usIgnoreUppercase);
576 FDialog.AlwaysSuggest := UserSetting(usSuggestSpellingCorrections);
577 FDialog.HideSpellingErrors := UserSetting(usHideSpellingErrors);
578 FDialog.HideGrammarErrors := UserSetting(usHideGrammarErrors);
579 FDialog.Execute;
580 finally
581 ThreadUnlock;
582 end;
583
584 // need list of custom dictionaries - default to CUSTOM.DIC (or query Word for it!!!)
585// FWord.CustomDictionaries
586
587end;
588
589procedure TMSWordThread.OnAppActivate(Sender: TObject);
590begin
591 if assigned(FOldOnActivate) then
592 FOldOnActivate(Sender);
593 RefocusSpellCheckDialog;
594end;
595
596procedure TMSWordThread.OnFormChange(Sender: TObject);
597begin
598 if assigned(FOldFormChange) then
599 FOldFormChange(Sender);
600 RefocusSpellCheckDialog;
601end;
602
603procedure TMSWordThread.OnThreadTerminate(Sender: TObject);
604begin
605 Application.OnActivate := FOldOnActivate;
606 Screen.OnActiveFormChange := FOldFormChange;
607// VarClear(FEmptyVar);
608 VarClear(FFalseVar);
609// VarClear(FTrueVar);
610 FWordSettings.Free;
611 FBeforeLines.Free;
612 FAfterLines.Free;
613 DeleteCriticalSection(FLock);
[841]614 Screen.Cursor := crDefault;
[1679]615 MSWordThread := nil;
616end;
617
618procedure TMSWordThread.RefocusSpellCheckDialog;
619begin
620 Application.ProcessMessages;
621 if Application.Active and (not FShowingMessage) and (FDocWindowHandle <> 0) then
622 begin
623 SetForegroundWindow(FDocWindowHandle);
624 SetFocus(FDocWindowHandle);
625 end;
626end;
627
628procedure TMSWordThread.ReportResults;
629var
630 icon: TShow508MessageIcon;
631begin
632 if FSucceeded then
633 icon := smiInfo
634 else
635 icon := smiWarning;
636 FShowingMessage := True;
637 try
638 ShowMsg(FResultMessage, icon, smbOK);
639 finally
640 FShowingMessage := False;
641 end;
642end;
643
644procedure TMSWordThread.RestoreWordSettings;
645
646 function Load(Index: integer): integer;
647 begin
648 if FWordSettings.Count > Index then
649 Result := Integer(FWordSettings[Index])
650 else
651 Result := 0
652 end;
653
654begin
655 FWord.Options.AutoFormatAsYouTypeApplyBorders := boolean(Load(wsAFAYTApplyBorders));
656 FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := boolean(Load(wsAFAYTApplyBulletedLists));
657 FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := boolean(Load(wsAFAYTApplyFirstIndents));
658 FWord.Options.AutoFormatAsYouTypeApplyHeadings := boolean(Load(wsAFAYTApplyHeadings));
659 FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := boolean(Load(wsAFAYTApplyNumberedLists));
660 FWord.Options.AutoFormatAsYouTypeApplyTables := boolean(Load(wsAFAYTApplyTables));
661 FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := boolean(Load(wsAFAYTAutoLetterWizard));
662 FWord.Options.AutoFormatAsYouTypeDefineStyles := boolean(Load(wsAFAYTDefineStyles));
663 FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := boolean(Load(wsAFAYTFormatListItemBeginning));
664 FWord.Options.AutoFormatAsYouTypeInsertClosings := boolean(Load(wsAFAYTInsertClosings));
665 FWord.Options.AutoFormatAsYouTypeReplaceQuotes := boolean(Load(wsAFAYTReplaceQuotes));
666 FWord.Options.AutoFormatAsYouTypeReplaceFractions := boolean(Load(wsAFAYTReplaceFractions));
667 FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := boolean(Load(wsAFAYTReplaceHyperlinks));
668 FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := boolean(Load(wsAFAYTReplaceOrdinals));
669 FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := boolean(Load(wsAFAYTReplacePlainTextEmphasis));
670 FWord.Options.AutoFormatAsYouTypeReplaceSymbols := boolean(Load(wsAFAYTReplaceSymbols));
671 FWord.Options.AutoFormatReplaceQuotes := boolean(Load(wsAutoFormatReplaceQuotes));
672 FWord.Options.TabIndentKey := boolean(Load(wsTabIndentKey));
673 FWord.WindowState := Load(wsWindowState);
674 FWord.Options.SaveInterval := Load(wsSaveInterval);
675 FDoc.TrackRevisions := boolean(Load(wsTrackRevisions));
676 FDoc.ShowRevisions := boolean(Load(wsShowRevisions));
677 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
678 FDoc.ShowSummary := boolean(Load(wsShowSummary));
679end;
680
681function TMSWordThread.RunWithErrorTrap(AMethod: TThreadMethod;
682 SpellCheckErrorMessage, GrammarCheckErrorMessage,
683 AdditionalErrorMessage: string; AllowRetry: boolean): boolean;
684var
685 RetryCount: integer;
686 Done: boolean;
687begin
688 RetryCount := 0;
689 Result := TRUE;
690 repeat
691 Done := TRUE;
692 try
693 AMethod;
694 except
695 on E: Exception do
696 begin
697 if not terminated then
[841]698 begin
[1679]699 inc(RetryCount);
700 Done := FALSE;
701 if RetryCount >= RETRY_MAX then
[841]702 begin
[1679]703 FError := E;
704 FAllowErrorRetry := AllowRetry;
705 if FSpellCheck then
706 FErrorText1 := SpellCheckErrorMessage
707 else
708 FErrorText1 := GrammarCheckErrorMessage;
709 FErrorText2 := AdditionalErrorMessage;
710 Synchronize(WordError);
711 if AllowRetry and (FRetryResult = smrRetry) then
712 RetryCount := 0
713 else
[841]714 begin
[1679]715 Result := FALSE;
716 Done := TRUE;
[841]717 end;
718 end;
719 end;
720 end;
721 end;
[1679]722 until Done;
[841]723end;
724
[1679]725procedure TMSWordThread.DoCheck;
[841]726begin
[1679]727 FDoc.Content.Text := FText;
728 FDoc.Content.SpellingChecked := False;
729 FDoc.Content.GrammarChecked := False;
730 if FSpellCheck then
731 begin
732 FDocDlg.Content.CheckSpelling;
733// FDoc.CheckSpelling(FNullStr, FEmptyVar, FEmptyVar, {Ignore, Suggest, }FNullStr, FNullStr,
734// FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr);
735 FSucceeded := FDoc.Content.SpellingChecked;
736 FText := FDoc.Content.Text;
737 end
738 else
739 begin
740 FDoc.Content.CheckGrammar;
741 FSucceeded := FDoc.Content.GrammarChecked;
742 FText := FDoc.Content.Text;
743 end;
744 FCanceled := (FText = '');
[841]745end;
746
[1679]747procedure TMSWordThread.SaveUserSettings;
748
749 procedure SaveSetting(Value: boolean; Index: integer);
750 begin
751 while length(SpellCheckerSettings) < Index do
752 SpellCheckerSettings := SpellCheckerSettings + ' ';
753 if Value then
754 SpellCheckerSettings[Index] := sTrueCode
755 else
756 SpellCheckerSettings[Index] := sFalseCode;
757 end;
[841]758begin
[1679]759 ThreadLock;
760 try
761 SpellCheckerSettings := '';
762 FDialog.Update;
763 SaveSetting(FDialog.AutomaticSpellChecking, usCheckSpellingAsYouType);
764 SaveSetting(FDialog.AutomaticGrammarChecking, usCheckGrammarAsYouType);
765 SaveSetting(FDialog.FilenamesEmailAliases, usIgnoreInternetAndFileAddresses);
766 SaveSetting(FDialog.IgnoreMixedDigits, usIgnoreMixedDigits);
767 SaveSetting(FDialog.IgnoreAllCaps, usIgnoreUppercase);
768 SaveSetting(FDialog.ForegroundGrammar, usCheckGrammarWithSpelling);
769 SaveSetting(FDialog.ShowStatistics, usShowReadabilityStatistics);
770 SaveSetting(FDialog.SuggestFromMainDictOnly, usSuggestFromMainDictionaryOnly);
771 SaveSetting(FDialog.AlwaysSuggest, usSuggestSpellingCorrections);
772 SaveSetting(FDialog.HideSpellingErrors, usHideSpellingErrors);
773 SaveSetting(FDialog.HideGrammarErrors, usHideGrammarErrors);
774 finally
775 ThreadUnlock;
776 end;
777 (*
7789 AlwaysSuggest,
7798 SuggestFromMainDictOnly,
7805 IgnoreAllCaps,
7814 IgnoreMixedDigits,
782 ResetIgnoreAll,
783 Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6,
784 CustomDict7, CustomDict8, CustomDict9, CustomDict10,
7851 AutomaticSpellChecking,
7863 FilenamesEmailAliases,
787 UserDict1,
7882 AutomaticGrammarChecking,
7896?? ForegroundGrammar,
7907 ShowStatistics,
791 Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch,
79210 HideGrammarErrors,
793 CheckSpelling, GrLidUI, SpLidUI,
794 DictLang1, DictLang2, DictLang3,
795 DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10,
79611 HideSpellingErrors,
797 HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell,
798 AraSpeller, ProcessCompoundNoun
799 *)
[841]800end;
801
[1679]802procedure TMSWordThread.SaveWordSettings;
[841]803
[1679]804 procedure Save(Value, Index: integer);
805 begin
806 while FWordSettings.Count <= Index do
807 FWordSettings.Add(nil);
808 FWordSettings[Index] := Pointer(Value);
809 end;
810
811begin
812 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBorders) , wsAFAYTApplyBorders);
813 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBulletedLists) , wsAFAYTApplyBulletedLists);
814 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyFirstIndents) , wsAFAYTApplyFirstIndents);
815 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyHeadings) , wsAFAYTApplyHeadings);
816 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyNumberedLists) , wsAFAYTApplyNumberedLists);
817 Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyTables) , wsAFAYTApplyTables);
818 Save(Ord(FWord.Options.AutoFormatAsYouTypeAutoLetterWizard) , wsAFAYTAutoLetterWizard);
819 Save(Ord(FWord.Options.AutoFormatAsYouTypeDefineStyles) , wsAFAYTDefineStyles);
820 Save(Ord(FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning) , wsAFAYTFormatListItemBeginning);
821 Save(Ord(FWord.Options.AutoFormatAsYouTypeInsertClosings) , wsAFAYTInsertClosings);
822 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceQuotes) , wsAFAYTReplaceQuotes);
823 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceFractions) , wsAFAYTReplaceFractions);
824 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks) , wsAFAYTReplaceHyperlinks);
825 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceOrdinals) , wsAFAYTReplaceOrdinals);
826 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis) , wsAFAYTReplacePlainTextEmphasis);
827 Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceSymbols) , wsAFAYTReplaceSymbols);
828 Save(Ord(FWord.Options.AutoFormatReplaceQuotes) , wsAutoFormatReplaceQuotes);
829 Save(Ord(FWord.Options.TabIndentKey) , wsTabIndentKey);
830 Save(Ord(FWord.WindowState) , wsWindowState);
831 Save(Ord(FWord.Options.SaveInterval) , wsSaveInterval);
832 Save(Ord(FDoc.TrackRevisions) , wsTrackRevisions);
833 Save(Ord(FDoc.ShowRevisions) , wsShowRevisions);
834 if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10}
835 Save(Ord(FDoc.ShowSummary) , wsShowSummary);
836end;
837
838procedure TMSWordThread.StartWord;
839begin
840 FWord := CoWordApplication.Create;
841 FWordVersion := StrToFloatDef(FWord.Version, 0.0); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Get Office version for office10 specific calls}
842end;
843
844procedure TMSWordThread.ThreadLock;
845begin
846 EnterCriticalSection(FLock);
847end;
848
849procedure TMSWordThread.ThreadUnlock;
850begin
851 LeaveCriticalSection(FLock);
852end;
853
854procedure TMSWordThread.TransferText;
855var
856 i: integer;
857 Lines: TStringList;
858begin
859 if FSucceeded and (not FCanceled) then
860 begin
861 Lines := TStringList.Create;
862 try
863 Lines.Text := FText;
864 // For some unknown reason spell check adds garbage lines to text
865 while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do
866 Lines.Delete(Lines.Count-1);
867 for i := 0 to FBeforeLines.Count-1 do
868 Lines.Insert(i, FBeforeLines[i]);
869 for i := 0 to FAfterLines.Count-1 do
870 Lines.Add(FAfterLines[i]);
871 FastAssign(Lines, FEditControl.Lines);
872 finally
873 Lines.Free;
874 end;
875 end;
876end;
877
878function TMSWordThread.UserSetting(Index: integer): boolean;
879begin
880 if SpellCheckerSettings = '' then
881 begin
882 case Index of
883 usCheckSpellingAsYouType: Result := True;
884 usCheckGrammarAsYouType: Result := False;
885 usIgnoreInternetAndFileAddresses: Result := True;
886 usIgnoreMixedDigits: Result := True;
887 usIgnoreUppercase: Result := True;
888 usCheckGrammarWithSpelling: Result := False;
889 usShowReadabilityStatistics: Result := False;
890 usSuggestFromMainDictionaryOnly: Result := False;
891 usSuggestSpellingCorrections: Result := True;
892 usHideSpellingErrors: Result := False;
893 usHideGrammarErrors: Result := True;
894 else Result := False;
895 end;
896 end
897 else
898 Result := copy(SpellCheckerSettings,Index,1) = sTrueCode;
899end;
900
901procedure TMSWordThread.ConfigDoc;
902begin
903 FDoc.TrackRevisions := False;
904 FDoc.ShowRevisions := False;
905 if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10}
906 FDoc.ShowSummary := False;
907 FWord.Height := 1000;
908 FWord.Width := 1000;
909 FWord.Top := -2000;
910 FWord.Left := -2000;
911end;
912
913procedure TMSWordThread.ConfigWord;
914begin
915// save all old values to FWord, restore when done.
916 FWord.Options.AutoFormatAsYouTypeApplyBorders := False;
917 FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := False;
918 FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := False;
919 FWord.Options.AutoFormatAsYouTypeApplyHeadings := False;
920 FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := False;
921 FWord.Options.AutoFormatAsYouTypeApplyTables := False;
922 FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := False;
923 FWord.Options.AutoFormatAsYouTypeDefineStyles := False;
924 FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := False;
925 FWord.Options.AutoFormatAsYouTypeInsertClosings := False;
926 FWord.Options.AutoFormatAsYouTypeReplaceQuotes := False;
927 FWord.Options.AutoFormatAsYouTypeReplaceFractions := False;
928 FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := False;
929 FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := False;
930 FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := False;
931 FWord.Options.AutoFormatAsYouTypeReplaceSymbols := False;
932 FWord.Options.AutoFormatReplaceQuotes := False;
933 FWord.Options.TabIndentKey := False;
934 FWord.WindowState := wdWindowStateNormal;
935 FWord.Options.SaveInterval := 0;
936 FWord.ResetIgnoreAll;
937end;
938
939procedure TMSWordThread.CreateDocument;
940var
941 DocType: OleVariant;
942begin
943 VariantInit(DocType);
944 try
945 DocType := wdNewBlankDocument;
946 FDoc := FWord.Documents.Add(FNullStr, FFalseVar, DocType, FFalseVar);
947 {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}
948// FDoc.Activate;
949 finally
950 VarClear(DocType);
951 end;
952end;
953
954constructor TMSWordThread.CreateThread(SpellCheck: boolean; AEditControl: TCustomMemo);
955
956 function WordDocTitle: string;
957 var
958 Guid: TGUID;
959 begin
960 if ActiveX.Succeeded(CreateGUID(Guid)) then
961 Result := GUIDToString(Guid)
962 else
963 Result := '';
964 Result := TX_WINDOW_TITLE + IntToStr(Application.Handle) + '/' + Result;
965 end;
966
967 function BeforeLineInvalid(Line: string): boolean;
968 var
969 i: integer;
970 begin
971 Result := (trim(Line) = '');
972 if not Result then
973 begin
974 for I := 1 to length(Line) do
975 if pos(Line[i], VALID_STARTING_CHARS) > 0 then exit;
976 Result := True;
977 end;
978 end;
979
980 procedure GetTextFromComponent;
981 var
982 Lines: TStrings;
983 begin
984 Lines := TStringList.Create;
985 try
986 FastAssign(AEditControl.Lines, Lines);
987
988 while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do
989 begin
990 FAfterLines.Insert(0, Lines[Lines.Count-1]);
991 Lines.Delete(Lines.Count-1);
992 end;
993
994 while (Lines.Count > 0) and (BeforeLineInvalid(Lines[0])) do
995 begin
996 FBeforeLines.Add(Lines[0]);
997 Lines.Delete(0);
998 end;
999
1000 FText := Lines.Text;
1001 finally
1002 Lines.Free;
1003 end;
1004 end;
1005
1006begin
1007 inherited Create(TRUE);
1008 Screen.Cursor := crHourGlass;
1009 InitializeCriticalSection(FLock);
1010 FBeforeLines := TStringList.Create;
1011 FAfterLines := TStringList.Create;
1012 FWordSettings := TList.Create;
1013 FSpellChecking := False;
1014 FEditControl := AEditControl;
1015// VariantInit(FEmptyVar);
1016 VariantInit(FFalseVar);
1017// VariantInit(FTrueVar);
1018 VariantInit(FNullStr);
1019// TVarData(FEmptyVar).VType := VT_EMPTY;
1020 TVarData(FFalseVar).VType := VT_BOOL;
1021// TVarData(FTrueVar).VType := VT_BOOL;
1022 TVarData(FNullStr).VType := VT_BSTR;
1023// FEmptyVar := 0;
1024 FFalseVar := 0;
1025// FTrueVar := -1;
1026 FNullStr := '';
1027 FDocWindowHandle := 0;
1028 FSpellCheck := SpellCheck;
1029
1030 GetTextFromComponent;
1031
1032 FSucceeded := FALSE;
1033 FCanceled := FALSE;
1034 FTitle := WordDocTitle;
1035 FreeOnTerminate := True;
1036 OnTerminate := OnThreadTerminate;
1037 FOldOnActivate := Application.OnActivate;
1038 Application.OnActivate := OnAppActivate;
1039 FOldFormChange := Screen.OnActiveFormChange;
1040 Screen.OnActiveFormChange := OnFormChange;
1041 Resume;
1042end;
1043
1044procedure TMSWordThread.WordError;
1045var
1046 btn: TShow508MessageButton;
1047 msg: string;
1048
1049 procedure Append(txt: string);
1050 begin
1051 if txt <> '' then
1052 msg := msg + CRLF + txt;
1053 end;
1054
1055begin
1056 if FAllowErrorRetry then
1057 btn := smbRetryCancel
1058 else
1059 btn := smbOK;
1060 msg := TX_ERROR_INTRO;
1061 Append(FErrorText1);
1062 if FError.Message <> '' then
1063 Append(FError.Message)
1064 else
1065 Append(TX_NO_DETAILS);
1066 Append(FErrorText2);
1067 FShowingMessage := True;
1068 try
1069 FRetryResult := ShowMsg(Msg, TX_ERROR_TITLE, smiError, btn);
1070 finally
1071 FShowingMessage := False;
1072 end;
1073end;
1074
1075initialization
1076
1077finalization
1078 KillSpellCheck;
1079
[841]1080end.
Note: See TracBrowser for help on using the repository browser.