Index: /cprs/branches/HealthSevak-CPRS/CPRS-Chart/uSpell.pas =================================================================== --- /cprs/branches/HealthSevak-CPRS/CPRS-Chart/uSpell.pas (revision 1704) +++ /cprs/branches/HealthSevak-CPRS/CPRS-Chart/uSpell.pas (revision 1705) @@ -1,5 +1,8 @@ unit uSpell; - +// Word settings need to be restored to origional settings! {$O-} + +{$DEFINE CPRS} +{$UNDEF CPRS} interface @@ -7,8 +10,7 @@ uses Windows, Messages, SysUtils, Classes, Controls, Forms, ComObj, StdCtrls, ComCtrls, - ORSystem, Word2000, ORFn, Variants, rCore, clipbrd; + rCore, ORFn, Word2000, Office_TLB, Variants, clipbrd, ActiveX, Contnrs, PSAPI, ExtCtrls; type - TSpellCheckAvailable = record Evaluated: boolean; @@ -16,14 +18,18 @@ end; -function SpellCheckAvailable: Boolean; function SpellCheckInProgress: Boolean; procedure KillSpellCheck; -procedure SpellCheckForControl(AnEditControl: TCustomMemo); +function SpellCheckAvailable: Boolean; +procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; added 2nd parameter} procedure GrammarCheckForControl(AnEditControl: TCustomMemo); -implementation +// Do Not Call these routines - internal use only +procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo); +procedure RefocusSpellCheckWindow; const - TX_WINDOW_TITLE = 'CPRS-Chart Spell Checking #'; + SpellCheckerSettingName = 'SpellCheckerSettings'; +//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; +{moved following from implementation section to this place to make them visible outside unit too} TX_NO_SPELL_CHECK = 'Spell checking is unavailable.'; TX_NO_GRAMMAR_CHECK = 'Grammar checking is unavailable.'; @@ -34,75 +40,187 @@ TX_SPELL_CANCELLED = 'Spelling check was cancelled before completion.'; TX_GRAMMAR_CANCELLED = 'Grammar check was cancelled before completion.'; + + TX_NO_CORRECTIONS = 'Corrections have NOT been applied.'; + TX_NO_DETAILS = 'No further details are available.'; + CRLF = #13#10; + +var + SpellCheckerSettings: string = ''; + + +implementation + +uses VAUtils, fSpellNotify, uInit, fHunSpell; + +const + TX_ERROR_TITLE = 'Error'; + TX_ERROR_INTRO = 'An error has occured.'; + TX_TRY_AGAIN = 'Would you like to try again?'; + TX_WINDOW_TITLE = 'CPRS-Chart Spell Checking #'; + { TX_NO_SPELL_CHECK = 'Spell checking is unavailable.'; +{ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ;} +{moved following from implementation section to this place to make them visible outside unit too} +//begin comment @ska +{ TX_NO_GRAMMAR_CHECK = 'Grammar checking is unavailable.'; + TX_SPELL_COMPLETE = 'The spelling check is complete.'; + TX_GRAMMAR_COMPLETE = 'The grammar check is complete.'; + TX_SPELL_ABORT = 'The spelling check terminated abnormally.'; + TX_GRAMMAR_ABORT = 'The grammar check terminated abnormally.'; + TX_SPELL_CANCELLED = 'Spelling check was cancelled before completion.'; + TX_GRAMMAR_CANCELLED = 'Grammar check was cancelled before completion.'; TX_NO_DETAILS = 'No further details are available.'; TX_NO_CORRECTIONS = 'Corrections have NOT been applied.'; - CR_LF = #13#10; - SPELL_CHECK = 'S'; - GRAMMAR_CHECK = 'G'; - -var - WindowList: TList; - OldList, NewList: TList; - MSWord: OleVariant; - uSpellCheckAvailable: TSpellCheckAvailable; - -function SpellCheckInProgress: boolean; -begin - Result := not VarIsEmpty(MSWord); -end; - -procedure KillSpellCheck; -begin - if SpellCheckInProgress then + CRLF = #13#10;} + //end comment @ska + +// TABOO_STARTING_CHARS = '!"#$%&()*+,./:;<=>?@[\]^_`{|}'; + VALID_STARTING_CHARS = '''-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; + +type + TMSWordThread = class(TThread) + private + FBeforeLines: TStringList; + FAfterLines: TStringList; + FWordSettings: TList; + FWordVersion: single;{To support Office 2010 & above ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine ; added new variable;} + FEditControl: TCustomMemo; + FShowingMessage: boolean; +// FEmptyVar: OleVariant; + FFalseVar: OleVariant; +// FTrueVar: OleVariant; + FNullStr: OleVariant; + FWord: WordApplication; + FDoc: WordDocument; + FDialog: OleVariant; + FDocDlg: OleVariant; + FText: string; + FSpellCheck: boolean; + FSucceeded: boolean; + FCanceled: boolean; + FTitle: string; + FDocWindowHandle: HWnd; + FOldFormChange: TNotifyEvent; + FOldOnActivate: TNotifyEvent; + FError: Exception; + FErrorText1: string; + FErrorText2: string; + FAllowErrorRetry: boolean; + FRetryResult: TShow508MessageResult; + FResultMessage: string; + FSpellChecking: boolean; + FLock: TRTLCriticalSection; + procedure OnFormChange(Sender: TObject); + procedure OnAppActivate(Sender: TObject); + procedure OnThreadTerminate(Sender: TObject); + procedure FindDocumentWindow; + procedure TransferText; + function RunWithErrorTrap(AMethod: TThreadMethod; + SpellCheckErrorMessage, GrammarCheckErrorMessage, AdditionalErrorMessage: string; + AllowRetry: boolean): boolean; + procedure WordError; + procedure StartWord; + procedure CreateDocument; + procedure DoCheck; + procedure ConfigWord; + procedure ConfigDoc; + procedure GetDialogs; + procedure SaveUserSettings; + procedure LoadUserSettings; + procedure ExitWord; + procedure ReportResults; + procedure SaveWordSettings; + procedure RestoreWordSettings; + function UserSetting(Index: integer): boolean; + procedure ThreadLock; + procedure ThreadUnlock; + protected + constructor CreateThread(SpellCheck: boolean; AEditControl: TCustomMemo); + procedure Execute; override; + public + procedure RefocusSpellCheckDialog; + property Text: string read FText; + property Succeeded: boolean read FSucceeded; + property Canceled: boolean read FCanceled; + end; + +var + MSWordThread: TMSWordThread = nil; + +function ControlHasText(SpellCheck: boolean; AnEditControl: TCustomMemo): boolean; +var + i: integer; +begin + Result := FALSE; + if not assigned(AnEditControl) then + ShowMsg('Spell Check programming error') + else + begin + for i := 0 to AnEditControl.Lines.Count - 1 do begin - MSWord.Quit(wdDoNotSaveChanges); - VarClear(MSWord); - end; -end; - -function SpellCheckTitle: string; -begin - Result := TX_WINDOW_TITLE + IntToStr(Application.Handle); -end; - -function GetWindows(Handle: HWND; Info: Pointer): BOOL; stdcall; -begin - Result := True; - WindowList.Add(Pointer(Handle)); -end; - -procedure GetWindowList(List: TList); -begin - WindowList := List; - EnumWindows(@GetWindows, 0); -end; - -procedure BringWordToFront(OldList, NewList: TList); -var - i, NameLen: integer; - WinName: array[0..160] of char; - NewWinName: PChar; - NewName: string; - -begin - NewName := SpellCheckTitle; - NameLen := length(NewName); - for i := 0 to NewList.Count-1 do - begin - if(OldList.IndexOf(NewList[i]) < 0) then - begin - GetWindowText(HWND(NewList[i]), WinName, sizeof(WinName) - 1); - if Pos('CPRS', WinName) > 0 then - NewWinName := PChar(Copy(WinName, Pos('CPRS', WinName), sizeof(WinName) - 1)) - else - NewWinName := WinName; - if StrLComp(NewWinName, pchar(NewName), NameLen)=0 then + if trim(AnEditControl.Lines[i]) <> '' then begin - Application.ProcessMessages; - SetForegroundWindow(HWND(NewList[i])); + Result := TRUE; break; end; end; - end; -end; + if not Result then + begin + if SpellCheck then + ShowMsg(TX_SPELL_COMPLETE) + else + ShowMsg(TX_GRAMMAR_COMPLETE) + end; + end; +end; + +function SpellCheckInProgress: boolean; +begin + Result := assigned(MSWordThread); +end; + +var + uSpellCheckAvailable: TSpellCheckAvailable; + +procedure KillSpellCheck; +var + checking: boolean; + WordHandle: HWnd; + ProcessID: DWORD; + ProcessHandle: THandle; + +begin + if assigned(MSWordThread) then + begin + with MSWordThread do + begin + ThreadLock; + try + checking := FSpellChecking; + WordHandle := FDocWindowHandle; + Terminate; + finally + ThreadUnlock; + end; + try + if checking then + begin + GetWindowThreadProcessId(WordHandle, ProcessID); + ProcessHandle := OpenProcess(PROCESS_TERMINATE, False, ProcessID); + try + TerminateProcess(ProcessHandle, 0); + finally + CloseHandle(ProcessHandle); + end; + end; + if assigned(MSWordThread) then + begin + WaitFor; + end; + except + end; + end; + end; +end; + { Spell Checking using Visual Basic for Applications script } @@ -128,164 +246,836 @@ end; -procedure SpellAndGrammarCheckForControl(var AnotherEditControl: TCustomMemo; ACheck: Char); -var - NoLFText, LFText: string; - OneChar: char; - ErrMsg: string; - FinishedChecking: boolean; - OldSaveInterval, i: integer; - MsgText: string; - FirstLineBlank: boolean; - OldLine0: string; -begin - if AnotherEditControl = nil then Exit; - OldList := TList.Create; - NewList := TList.Create; - FinishedChecking := False; - FirstLineBlank := False; - NoLFText := ''; - OldLine0 := ''; - ClipBoard.Clear; +{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine, added new proc} +procedure DoHanSpellCheck(anEditControl: TCustomMemo); +//Initiates OpenSource (HunSpell) based Spell check +begin + SuspendTimeout; try +{being a class function, we don't have to create an object instance beforehand} + TfrmHunSpell.DoHunSpellCheck(AnEditControl); + finally + ResumeTimeout; + end; +end; + +procedure DoSpellCheck(SpellCheck: boolean; AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Added second parameter} +var + frmSpellNotify: TfrmSpellNotify; +begin +{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; commented out net line} +//if assigned(MSWordThread) then exit; {commented out this line and instead added additional check for OpenSource in next line} + if (assigned(MSWordThread) and not OpenSource) then exit; + + if ControlHasText(SpellCheck, AnEditControl) then +{//ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine} +//Begin @ska ; added next three new lines + if OpenSource and SpellCheck then + DoHanSpellCheck(AnEditControl) + else +//end @ska; 01 May 2015 + begin + frmSpellNotify := TfrmSpellNotify.Create(Application); try - GetWindowList(OldList); + SuspendTimeout; try - Screen.Cursor := crHourGlass; - MSWord := CreateOLEObject('Word.Application'); - except // MSWord not available, so exit now - Screen.Cursor := crDefault; - case ACheck of - SPELL_CHECK : MsgText := TX_NO_SPELL_CHECK; - GRAMMAR_CHECK: MsgText := TX_NO_GRAMMAR_CHECK; - else MsgText := '' - end; - Application.MessageBox(PChar(MsgText), PChar(Application.Title), MB_ICONWARNING); - Exit; - end; - - GetWindowList(NewList); - try - MSWord.Application.Caption := SpellCheckTitle; - // Position Word off screen to avoid having document visible... - MSWord.WindowState := 0; - MSWord.Top := -3000; - OldSaveInterval := MSWord.Application.Options.SaveInterval; - MSWord.Application.Options.SaveInterval := 0; - MSWord.Application.Options.AutoFormatReplaceQuotes := False; - MSWord.Application.Options.AutoFormatAsYouTypeReplaceQuotes := False; - MSWord.ResetIgnoreAll; - - MSWord.Documents.Add; // FileNew - MSWord.ActiveDocument.TrackRevisions := False; - with AnotherEditControl do - if (Lines.Count > 0) and (not ContainsVisibleChar(Lines[0])) then - begin - FirstLineBlank := True; //MS bug when spell-checking document with blank first line (RV - v22.6) - OldLine0 := Lines[0]; - Lines.Delete(0); - end; - MSWord.ActiveDocument.Content.Text := (AnotherEditControl.Text); // The Text property returns the plain, unformatted text of the selection or range. - // When you set this property, the text of the range or selection is replaced. - BringWordToFront(OldList, NewList); - MSWord.ActiveDocument.Content.SpellingChecked := False; - MSWord.ActiveDocument.Content.GrammarChecked := False; - - case ACheck of - SPELL_CHECK : begin - MSWord.ActiveDocument.Content.CheckSpelling; // ToolsSpelling - FinishedChecking := MSWord.ActiveDocument.Content.SpellingChecked; - end; - GRAMMAR_CHECK: begin - MSWord.ActiveDocument.Content.CheckGrammar; // ToolsGrammar - FinishedChecking := MSWord.ActiveDocument.Content.GrammarChecked; - end; - end; - if FinishedChecking then // not cancelled? - NoLFText := MSWord.ActiveDocument.Content.Text // EditSelectAll - else - NoLFText := ''; + frmSpellNotify.SpellCheck := SpellCheck; + frmSpellNotify.EditControl := AnEditControl; + frmSpellNotify.ShowModal; finally - Screen.Cursor := crDefault; - MSWord.Application.Options.SaveInterval := OldSaveInterval; - case ACheck of - SPELL_CHECK : FinishedChecking := MSWord.ActiveDocument.Content.SpellingChecked; - GRAMMAR_CHECK: FinishedChecking := MSWord.ActiveDocument.Content.GrammarChecked; - end; - MSWord.Quit(wdDoNotSaveChanges); - VarClear(MSWord); + ResumeTimeout; end; finally - OldList.Free; - NewList.Free; - end; - except - on E: Exception do + frmSpellNotify.Free; + end; + end; +end; + +procedure InternalSpellCheck(SpellCheck: boolean; EditControl: TCustomMemo); +begin + MSWordThread := TMSWordThread.CreateThread(SpellCheck, EditControl); + while assigned(MSWordThread) do + begin + Application.ProcessMessages; + sleep(50); + end; +end; + +procedure RefocusSpellCheckWindow; +begin + if assigned(MSWordThread) then + MSWordThread.RefocusSpellCheckDialog; +end; + +procedure SpellCheckForControl(AnEditControl: TCustomMemo; OpenSource: Boolean = False); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter} +begin + DoSpellCheck(True, AnEditControl, OpenSource); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter} +end; + +procedure GrammarCheckForControl(AnEditControl: TCustomMemo); +begin + DoSpellCheck(False, AnEditControl); +end; +{ TMSWordThread } + +const + RETRY_MAX = 3; + + usCheckSpellingAsYouType = 1; + usCheckGrammarAsYouType = 2; + usIgnoreInternetAndFileAddresses = 3; + usIgnoreMixedDigits = 4; + usIgnoreUppercase = 5; + usCheckGrammarWithSpelling = 6; + usShowReadabilityStatistics = 7; + usSuggestFromMainDictionaryOnly = 8; + usSuggestSpellingCorrections = 9; + usHideSpellingErrors = 10; + usHideGrammarErrors = 11; + + sTrueCode = 'T'; + sFalseCode = 'F'; + + // AFAYT = AutoFormatAsYouType + wsAFAYTApplyBorders = 0; + wsAFAYTApplyBulletedLists = 1; + wsAFAYTApplyFirstIndents = 2; + wsAFAYTApplyHeadings = 3; + wsAFAYTApplyNumberedLists = 4; + wsAFAYTApplyTables = 5; + wsAFAYTAutoLetterWizard = 6; + wsAFAYTDefineStyles = 7; + wsAFAYTFormatListItemBeginning = 8; + wsAFAYTInsertClosings = 9; + wsAFAYTReplaceQuotes = 10; + wsAFAYTReplaceFractions = 11; + wsAFAYTReplaceHyperlinks = 12; + wsAFAYTReplaceOrdinals = 13; + wsAFAYTReplacePlainTextEmphasis = 14; + wsAFAYTReplaceSymbols = 15; + wsAutoFormatReplaceQuotes = 16; + wsTabIndentKey = 17; + wsWindowState = 18; + wsSaveInterval = 19; + wsTrackRevisions = 20; + wsShowRevisions = 21; + wsShowSummary = 22; {not used for Word 2010; ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; added second parameter } + +procedure TMSWordThread.Execute; +var + ok: boolean; + + procedure EnableAppActivation; + begin + FWord.Caption := FTitle; + Synchronize(FindDocumentWindow); + end; + + procedure Run(AMethod: TThreadMethod; force: boolean = false); + begin + if terminated then exit; + if ok or force then + begin + ok := RunWithErrorTrap(AMethod, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE); + end; + end; + + procedure BuildResultMessage; + begin + FResultMessage := ''; + if FCanceled or (not FSucceeded) then + begin + if FSpellCheck then + FResultMessage := TX_SPELL_CANCELLED + else + FResultMessage := TX_GRAMMAR_CANCELLED; + FResultMessage := FResultMessage + CRLF + TX_NO_CORRECTIONS; + end + else + if FSucceeded then + begin + if FSpellCheck then + FResultMessage := TX_SPELL_COMPLETE + else + FResultMessage := TX_GRAMMAR_COMPLETE; + end; + end; + + procedure SetStatus(value, force: boolean); + begin + if ok or force then + begin + ThreadLock; + FSpellChecking := value; + ThreadUnlock; + end; + end; + +begin + CoInitialize(nil); + ok := true; + try + if RunWithErrorTrap(StartWord, TX_NO_SPELL_CHECK, TX_NO_GRAMMAR_CHECK, TX_TRY_AGAIN, TRUE) then + begin + try + if RunWithErrorTrap(CreateDocument, TX_SPELL_ABORT, TX_GRAMMAR_ABORT, '', FALSE) then + begin + try + EnableAppActivation; + Run(SaveWordSettings); + Run(ConfigWord); + Run(ConfigDoc); + Run(GetDialogs); + Run(LoadUserSettings); + SetStatus(True, False); + Run(DoCheck); + SetStatus(False, True); + Run(SaveUserSettings); + Run(RestoreWordSettings); + Run(ExitWord, True); + if ok and (not terminated) then + begin + Synchronize(TransferText); + BuildResultMessage; + Synchronize(ReportResults); + end; + finally + FDoc := nil; + end; + end; + finally + FWord := nil; + end; + end; + finally + CoUninitialize; + end; +end; + +procedure TMSWordThread.ExitWord; +var + Save: OleVariant; + Doc: OleVariant; + +begin + VarClear(FDialog); + VarClear(FDocDlg); + VariantInit(Save); + VariantInit(Doc); + try + Save := wdDoNotSaveChanges; + Doc := wdWordDocument; + FWord.Quit(Save, Doc, FFalseVar); + finally + VarClear(Save); + VarClear(Doc); + end; +end; + +var + WindowTitle: string; + WindowHandle: HWnd; + +function FindDocWindow(Handle: HWND; Info: Pointer): BOOL; stdcall; +var + title: string; +begin + title := GetWindowTitle(Handle); + if title = WindowTitle then + begin + WindowHandle := Handle; + Result := FALSE; + end + else + Result := True; +end; + +procedure TMSWordThread.FindDocumentWindow; +begin + WindowTitle := FTitle; + WindowHandle := 0; + EnumWindows(@FindDocWindow, 0); + FDocWindowHandle := WindowHandle; +end; + +procedure TMSWordThread.GetDialogs; +//var +// DispParams: TDispParams; +// OleArgs: array of OleVariant; +// ExcepInfo: TExcepInfo; +// Status: integer; +begin +// SetLength(OleArgs, 1); +// VariantInit(OleArgs[0]); +// try + VariantInit(FDialog); + FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar); + VariantInit(FDocDlg); + FDocDlg := FWord.ActiveDocument; +(* OleArgs[0] := wdDialogToolsOptionsSpellingAndGrammar; + DispParams.rgvarg := @OleArgs[0]; + DispParams.cArgs := 1; + DispParams.rgdispidNamedArgs := nil; + DispParams.cNamedArgs := 0; +// FDialog := FWord.Dialogs.Item(wdDialogToolsOptionsSpellingAndGrammar); + // dispid 0 is the Item method + Status := FWord.Dialogs.Invoke(0, GUID_NULL, LOCALE_USER_DEFAULT, + DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDialog, @ExcepInfo, nil); + if Status <> S_OK then + DispatchInvokeError(Status, ExcepInfo); + VariantInit(FDocDlg); + DispParams.rgvarg := nil; + DispParams.cArgs := 0; + Status := FWord.Invoke(3, GUID_NULL, LOCALE_USER_DEFAULT, + DISPATCH_METHOD or DISPATCH_PROPERTYGET, DispParams, @FDocDlg, @ExcepInfo, nil); + if Status <> S_OK then + DispatchInvokeError(Status, ExcepInfo); + finally + VarClear(OleArgs[0]); + SetLength(OleArgs, 0); + end; *) +end; + +procedure TMSWordThread.LoadUserSettings; +begin + // load FUserSettings from server + + // these are default values + (* +9 AlwaysSuggest, +8 SuggestFromMainDictOnly, +5 IgnoreAllCaps, +4 IgnoreMixedDigits, + ResetIgnoreAll, + Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6, + CustomDict7, CustomDict8, CustomDict9, CustomDict10, +1 AutomaticSpellChecking, +3 FilenamesEmailAliases, + UserDict1, +2 AutomaticGrammarChecking, +6?? ForegroundGrammar, +7 ShowStatistics, + Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch, +10 HideGrammarErrors, + CheckSpelling, GrLidUI, SpLidUI, + DictLang1, DictLang2, DictLang3, + DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10, +11 HideSpellingErrors, + HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell, + AraSpeller, ProcessCompoundNoun + *) +// FDialog. + ThreadLock; + try + FDialog.AutomaticSpellChecking := UserSetting(usCheckSpellingAsYouType); + FDialog.AutomaticGrammarChecking := UserSetting(usCheckGrammarAsYouType); + FDialog.FilenamesEmailAliases := UserSetting(usIgnoreInternetAndFileAddresses); + FDialog.IgnoreMixedDigits := UserSetting(usIgnoreMixedDigits); + FDialog.ForegroundGrammar := UserSetting(usCheckGrammarWithSpelling); + FDialog.ShowStatistics := UserSetting(usShowReadabilityStatistics); + FDialog.SuggestFromMainDictOnly := UserSetting(usSuggestFromMainDictionaryOnly); + FDialog.IgnoreAllCaps := UserSetting(usIgnoreUppercase); + FDialog.AlwaysSuggest := UserSetting(usSuggestSpellingCorrections); + FDialog.HideSpellingErrors := UserSetting(usHideSpellingErrors); + FDialog.HideGrammarErrors := UserSetting(usHideGrammarErrors); + FDialog.Execute; + finally + ThreadUnlock; + end; + + // need list of custom dictionaries - default to CUSTOM.DIC (or query Word for it!!!) +// FWord.CustomDictionaries + +end; + +procedure TMSWordThread.OnAppActivate(Sender: TObject); +begin + if assigned(FOldOnActivate) then + FOldOnActivate(Sender); + RefocusSpellCheckDialog; +end; + +procedure TMSWordThread.OnFormChange(Sender: TObject); +begin + if assigned(FOldFormChange) then + FOldFormChange(Sender); + RefocusSpellCheckDialog; +end; + +procedure TMSWordThread.OnThreadTerminate(Sender: TObject); +begin + Application.OnActivate := FOldOnActivate; + Screen.OnActiveFormChange := FOldFormChange; +// VarClear(FEmptyVar); + VarClear(FFalseVar); +// VarClear(FTrueVar); + FWordSettings.Free; + FBeforeLines.Free; + FAfterLines.Free; + DeleteCriticalSection(FLock); + Screen.Cursor := crDefault; + MSWordThread := nil; +end; + +procedure TMSWordThread.RefocusSpellCheckDialog; +begin + Application.ProcessMessages; + if Application.Active and (not FShowingMessage) and (FDocWindowHandle <> 0) then + begin + SetForegroundWindow(FDocWindowHandle); + SetFocus(FDocWindowHandle); + end; +end; + +procedure TMSWordThread.ReportResults; +var + icon: TShow508MessageIcon; +begin + if FSucceeded then + icon := smiInfo + else + icon := smiWarning; + FShowingMessage := True; + try + ShowMsg(FResultMessage, icon, smbOK); + finally + FShowingMessage := False; + end; +end; + +procedure TMSWordThread.RestoreWordSettings; + + function Load(Index: integer): integer; + begin + if FWordSettings.Count > Index then + Result := Integer(FWordSettings[Index]) + else + Result := 0 + end; + +begin + FWord.Options.AutoFormatAsYouTypeApplyBorders := boolean(Load(wsAFAYTApplyBorders)); + FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := boolean(Load(wsAFAYTApplyBulletedLists)); + FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := boolean(Load(wsAFAYTApplyFirstIndents)); + FWord.Options.AutoFormatAsYouTypeApplyHeadings := boolean(Load(wsAFAYTApplyHeadings)); + FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := boolean(Load(wsAFAYTApplyNumberedLists)); + FWord.Options.AutoFormatAsYouTypeApplyTables := boolean(Load(wsAFAYTApplyTables)); + FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := boolean(Load(wsAFAYTAutoLetterWizard)); + FWord.Options.AutoFormatAsYouTypeDefineStyles := boolean(Load(wsAFAYTDefineStyles)); + FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := boolean(Load(wsAFAYTFormatListItemBeginning)); + FWord.Options.AutoFormatAsYouTypeInsertClosings := boolean(Load(wsAFAYTInsertClosings)); + FWord.Options.AutoFormatAsYouTypeReplaceQuotes := boolean(Load(wsAFAYTReplaceQuotes)); + FWord.Options.AutoFormatAsYouTypeReplaceFractions := boolean(Load(wsAFAYTReplaceFractions)); + FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := boolean(Load(wsAFAYTReplaceHyperlinks)); + FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := boolean(Load(wsAFAYTReplaceOrdinals)); + FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := boolean(Load(wsAFAYTReplacePlainTextEmphasis)); + FWord.Options.AutoFormatAsYouTypeReplaceSymbols := boolean(Load(wsAFAYTReplaceSymbols)); + FWord.Options.AutoFormatReplaceQuotes := boolean(Load(wsAutoFormatReplaceQuotes)); + FWord.Options.TabIndentKey := boolean(Load(wsTabIndentKey)); + FWord.WindowState := Load(wsWindowState); + FWord.Options.SaveInterval := Load(wsSaveInterval); + FDoc.TrackRevisions := boolean(Load(wsTrackRevisions)); + FDoc.ShowRevisions := boolean(Load(wsShowRevisions)); + 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 + FDoc.ShowSummary := boolean(Load(wsShowSummary)); +end; + +function TMSWordThread.RunWithErrorTrap(AMethod: TThreadMethod; + SpellCheckErrorMessage, GrammarCheckErrorMessage, + AdditionalErrorMessage: string; AllowRetry: boolean): boolean; +var + RetryCount: integer; + Done: boolean; +begin + RetryCount := 0; + Result := TRUE; + repeat + Done := TRUE; + try + AMethod; + except + on E: Exception do begin - ErrMsg := E.Message; - FinishedChecking := False; + if not terminated then + begin + inc(RetryCount); + Done := FALSE; + if RetryCount >= RETRY_MAX then + begin + FError := E; + FAllowErrorRetry := AllowRetry; + if FSpellCheck then + FErrorText1 := SpellCheckErrorMessage + else + FErrorText1 := GrammarCheckErrorMessage; + FErrorText2 := AdditionalErrorMessage; + Synchronize(WordError); + if AllowRetry and (FRetryResult = smrRetry) then + RetryCount := 0 + else + begin + Result := FALSE; + Done := TRUE; + end; + end; + end; end; - end; - - Screen.Cursor := crDefault; - Application.BringToFront; - if FinishedChecking then + end; + until Done; +end; + +procedure TMSWordThread.DoCheck; +begin + FDoc.Content.Text := FText; + FDoc.Content.SpellingChecked := False; + FDoc.Content.GrammarChecked := False; + if FSpellCheck then + begin + FDocDlg.Content.CheckSpelling; +// FDoc.CheckSpelling(FNullStr, FEmptyVar, FEmptyVar, {Ignore, Suggest, }FNullStr, FNullStr, +// FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr, FNullStr); + FSucceeded := FDoc.Content.SpellingChecked; + FText := FDoc.Content.Text; + end + else + begin + FDoc.Content.CheckGrammar; + FSucceeded := FDoc.Content.GrammarChecked; + FText := FDoc.Content.Text; + end; + FCanceled := (FText = ''); +end; + +procedure TMSWordThread.SaveUserSettings; + + procedure SaveSetting(Value: boolean; Index: integer); + begin + while length(SpellCheckerSettings) < Index do + SpellCheckerSettings := SpellCheckerSettings + ' '; + if Value then + SpellCheckerSettings[Index] := sTrueCode + else + SpellCheckerSettings[Index] := sFalseCode; + end; +begin + ThreadLock; + try + SpellCheckerSettings := ''; + FDialog.Update; + SaveSetting(FDialog.AutomaticSpellChecking, usCheckSpellingAsYouType); + SaveSetting(FDialog.AutomaticGrammarChecking, usCheckGrammarAsYouType); + SaveSetting(FDialog.FilenamesEmailAliases, usIgnoreInternetAndFileAddresses); + SaveSetting(FDialog.IgnoreMixedDigits, usIgnoreMixedDigits); + SaveSetting(FDialog.IgnoreAllCaps, usIgnoreUppercase); + SaveSetting(FDialog.ForegroundGrammar, usCheckGrammarWithSpelling); + SaveSetting(FDialog.ShowStatistics, usShowReadabilityStatistics); + SaveSetting(FDialog.SuggestFromMainDictOnly, usSuggestFromMainDictionaryOnly); + SaveSetting(FDialog.AlwaysSuggest, usSuggestSpellingCorrections); + SaveSetting(FDialog.HideSpellingErrors, usHideSpellingErrors); + SaveSetting(FDialog.HideGrammarErrors, usHideGrammarErrors); + finally + ThreadUnlock; + end; + (* +9 AlwaysSuggest, +8 SuggestFromMainDictOnly, +5 IgnoreAllCaps, +4 IgnoreMixedDigits, + ResetIgnoreAll, + Type, CustomDict1, CustomDict2, CustomDict3, CustomDict4, CustomDict5, CustomDict6, + CustomDict7, CustomDict8, CustomDict9, CustomDict10, +1 AutomaticSpellChecking, +3 FilenamesEmailAliases, + UserDict1, +2 AutomaticGrammarChecking, +6?? ForegroundGrammar, +7 ShowStatistics, + Options, RecheckDocument, IgnoreAuxFind, IgnoreMissDictSearch, +10 HideGrammarErrors, + CheckSpelling, GrLidUI, SpLidUI, + DictLang1, DictLang2, DictLang3, + DictLang4, DictLang5, DictLang6, DictLang7, DictLang8, DictLang9, DictLang10, +11 HideSpellingErrors, + HebSpellStart, InitialAlefHamza, FinalYaa, GermanPostReformSpell, + AraSpeller, ProcessCompoundNoun + *) +end; + +procedure TMSWordThread.SaveWordSettings; + + procedure Save(Value, Index: integer); + begin + while FWordSettings.Count <= Index do + FWordSettings.Add(nil); + FWordSettings[Index] := Pointer(Value); + end; + +begin + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBorders) , wsAFAYTApplyBorders); + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyBulletedLists) , wsAFAYTApplyBulletedLists); + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyFirstIndents) , wsAFAYTApplyFirstIndents); + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyHeadings) , wsAFAYTApplyHeadings); + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyNumberedLists) , wsAFAYTApplyNumberedLists); + Save(Ord(FWord.Options.AutoFormatAsYouTypeApplyTables) , wsAFAYTApplyTables); + Save(Ord(FWord.Options.AutoFormatAsYouTypeAutoLetterWizard) , wsAFAYTAutoLetterWizard); + Save(Ord(FWord.Options.AutoFormatAsYouTypeDefineStyles) , wsAFAYTDefineStyles); + Save(Ord(FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning) , wsAFAYTFormatListItemBeginning); + Save(Ord(FWord.Options.AutoFormatAsYouTypeInsertClosings) , wsAFAYTInsertClosings); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceQuotes) , wsAFAYTReplaceQuotes); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceFractions) , wsAFAYTReplaceFractions); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks) , wsAFAYTReplaceHyperlinks); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceOrdinals) , wsAFAYTReplaceOrdinals); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis) , wsAFAYTReplacePlainTextEmphasis); + Save(Ord(FWord.Options.AutoFormatAsYouTypeReplaceSymbols) , wsAFAYTReplaceSymbols); + Save(Ord(FWord.Options.AutoFormatReplaceQuotes) , wsAutoFormatReplaceQuotes); + Save(Ord(FWord.Options.TabIndentKey) , wsTabIndentKey); + Save(Ord(FWord.WindowState) , wsWindowState); + Save(Ord(FWord.Options.SaveInterval) , wsSaveInterval); + Save(Ord(FDoc.TrackRevisions) , wsTrackRevisions); + Save(Ord(FDoc.ShowRevisions) , wsShowRevisions); + if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10} + Save(Ord(FDoc.ShowSummary) , wsShowSummary); +end; + +procedure TMSWordThread.StartWord; +begin + FWord := CoWordApplication.Create; + FWordVersion := StrToFloatDef(FWord.Version, 0.0); {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Get Office version for office10 specific calls} +end; + +procedure TMSWordThread.ThreadLock; +begin + EnterCriticalSection(FLock); +end; + +procedure TMSWordThread.ThreadUnlock; +begin + LeaveCriticalSection(FLock); +end; + +procedure TMSWordThread.TransferText; +var + i: integer; + Lines: TStringList; +begin + if FSucceeded and (not FCanceled) then + begin + Lines := TStringList.Create; + try + Lines.Text := FText; + // For some unknown reason spell check adds garbage lines to text + while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do + Lines.Delete(Lines.Count-1); + for i := 0 to FBeforeLines.Count-1 do + Lines.Insert(i, FBeforeLines[i]); + for i := 0 to FAfterLines.Count-1 do + Lines.Add(FAfterLines[i]); + FastAssign(Lines, FEditControl.Lines); + finally + Lines.Free; + end; + end; +end; + +function TMSWordThread.UserSetting(Index: integer): boolean; +begin + if SpellCheckerSettings = '' then + begin + case Index of + usCheckSpellingAsYouType: Result := True; + usCheckGrammarAsYouType: Result := False; + usIgnoreInternetAndFileAddresses: Result := True; + usIgnoreMixedDigits: Result := True; + usIgnoreUppercase: Result := True; + usCheckGrammarWithSpelling: Result := False; + usShowReadabilityStatistics: Result := False; + usSuggestFromMainDictionaryOnly: Result := False; + usSuggestSpellingCorrections: Result := True; + usHideSpellingErrors: Result := False; + usHideGrammarErrors: Result := True; + else Result := False; + end; + end + else + Result := copy(SpellCheckerSettings,Index,1) = sTrueCode; +end; + +procedure TMSWordThread.ConfigDoc; +begin + FDoc.TrackRevisions := False; + FDoc.ShowRevisions := False; + if (FWordVersion < 13) then {ska@WorldVista ; 01 May 2015; to implement OpenSource SpellCheck Engine; Only call next line if office verion if version < office10} + FDoc.ShowSummary := False; + FWord.Height := 1000; + FWord.Width := 1000; + FWord.Top := -2000; + FWord.Left := -2000; +end; + +procedure TMSWordThread.ConfigWord; +begin +// save all old values to FWord, restore when done. + FWord.Options.AutoFormatAsYouTypeApplyBorders := False; + FWord.Options.AutoFormatAsYouTypeApplyBulletedLists := False; + FWord.Options.AutoFormatAsYouTypeApplyFirstIndents := False; + FWord.Options.AutoFormatAsYouTypeApplyHeadings := False; + FWord.Options.AutoFormatAsYouTypeApplyNumberedLists := False; + FWord.Options.AutoFormatAsYouTypeApplyTables := False; + FWord.Options.AutoFormatAsYouTypeAutoLetterWizard := False; + FWord.Options.AutoFormatAsYouTypeDefineStyles := False; + FWord.Options.AutoFormatAsYouTypeFormatListItemBeginning := False; + FWord.Options.AutoFormatAsYouTypeInsertClosings := False; + FWord.Options.AutoFormatAsYouTypeReplaceQuotes := False; + FWord.Options.AutoFormatAsYouTypeReplaceFractions := False; + FWord.Options.AutoFormatAsYouTypeReplaceHyperlinks := False; + FWord.Options.AutoFormatAsYouTypeReplaceOrdinals := False; + FWord.Options.AutoFormatAsYouTypeReplacePlainTextEmphasis := False; + FWord.Options.AutoFormatAsYouTypeReplaceSymbols := False; + FWord.Options.AutoFormatReplaceQuotes := False; + FWord.Options.TabIndentKey := False; + FWord.WindowState := wdWindowStateNormal; + FWord.Options.SaveInterval := 0; + FWord.ResetIgnoreAll; +end; + +procedure TMSWordThread.CreateDocument; +var + DocType: OleVariant; +begin + VariantInit(DocType); + try + DocType := wdNewBlankDocument; + FDoc := FWord.Documents.Add(FNullStr, FFalseVar, DocType, FFalseVar); + {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} +// FDoc.Activate; + finally + VarClear(DocType); + end; +end; + +constructor TMSWordThread.CreateThread(SpellCheck: boolean; AEditControl: TCustomMemo); + + function WordDocTitle: string; + var + Guid: TGUID; + begin + if ActiveX.Succeeded(CreateGUID(Guid)) then + Result := GUIDToString(Guid) + else + Result := ''; + Result := TX_WINDOW_TITLE + IntToStr(Application.Handle) + '/' + Result; + end; + + function BeforeLineInvalid(Line: string): boolean; + var + i: integer; + begin + Result := (trim(Line) = ''); + if not Result then begin - if (Length(NoLFText) > 0) then - begin - LFText := ''; - for i := 1 to Length(NoLFText) do - begin - OneChar := NoLFText[i]; - LFText := LFText + OneChar; - if OneChar = #13 then LFText := LFText + #10; - end; - with AnotherEditControl do if Lines.Count > 0 then - begin - Text := LFText; - if FirstLineBlank then Text := OldLine0 + Text; - end; - case ACheck of - SPELL_CHECK : MsgText := TX_SPELL_COMPLETE; - GRAMMAR_CHECK: MsgText := TX_GRAMMAR_COMPLETE; - else MsgText := '' - end; - Application.MessageBox(PChar(MsgText), PChar(Application.Title), MB_ICONINFORMATION); - end - else - begin - case ACheck of - SPELL_CHECK : MsgText := TX_SPELL_CANCELLED; - GRAMMAR_CHECK: MsgText := TX_GRAMMAR_CANCELLED; - else MsgText := '' - end; - Application.MessageBox(PChar(MsgText + CR_LF + CR_LF + TX_NO_CORRECTIONS), PChar(Application.Title), MB_ICONINFORMATION); - end; - end - else // error during spell or grammar check - begin - case ACheck of - SPELL_CHECK : MsgText := TX_SPELL_ABORT; - GRAMMAR_CHECK: MsgText := TX_GRAMMAR_ABORT; - else MsgText := '' + for I := 1 to length(Line) do + if pos(Line[i], VALID_STARTING_CHARS) > 0 then exit; + Result := True; + end; + end; + + procedure GetTextFromComponent; + var + Lines: TStrings; + begin + Lines := TStringList.Create; + try + FastAssign(AEditControl.Lines, Lines); + + while (Lines.Count > 0) and (trim(Lines[Lines.Count-1]) = '') do + begin + FAfterLines.Insert(0, Lines[Lines.Count-1]); + Lines.Delete(Lines.Count-1); end; - if ErrMsg = '' then ErrMsg := TX_NO_DETAILS; - Application.MessageBox(PChar(MsgText + CR_LF + ErrMsg + CR_LF + CR_LF + TX_NO_CORRECTIONS), PChar(Application.Title), MB_ICONWARNING); - end; - SendMessage(TRichEdit(AnotherEditControl).Handle, WM_VSCROLL, SB_TOP, 0); - AnotherEditControl.SetFocus; -end; - -procedure SpellCheckForControl(AnEditControl: TCustomMemo); -begin - if AnEditControl = nil then Exit; - SpellAndGrammarCheckForControl(AnEditControl, SPELL_CHECK); -end; - -procedure GrammarCheckForControl(AnEditControl: TCustomMemo); -begin - if AnEditControl = nil then Exit; - SpellAndGrammarCheckForControl(AnEditControl, GRAMMAR_CHECK); -end; - + + while (Lines.Count > 0) and (BeforeLineInvalid(Lines[0])) do + begin + FBeforeLines.Add(Lines[0]); + Lines.Delete(0); + end; + + FText := Lines.Text; + finally + Lines.Free; + end; + end; + +begin + inherited Create(TRUE); + Screen.Cursor := crHourGlass; + InitializeCriticalSection(FLock); + FBeforeLines := TStringList.Create; + FAfterLines := TStringList.Create; + FWordSettings := TList.Create; + FSpellChecking := False; + FEditControl := AEditControl; +// VariantInit(FEmptyVar); + VariantInit(FFalseVar); +// VariantInit(FTrueVar); + VariantInit(FNullStr); +// TVarData(FEmptyVar).VType := VT_EMPTY; + TVarData(FFalseVar).VType := VT_BOOL; +// TVarData(FTrueVar).VType := VT_BOOL; + TVarData(FNullStr).VType := VT_BSTR; +// FEmptyVar := 0; + FFalseVar := 0; +// FTrueVar := -1; + FNullStr := ''; + FDocWindowHandle := 0; + FSpellCheck := SpellCheck; + + GetTextFromComponent; + + FSucceeded := FALSE; + FCanceled := FALSE; + FTitle := WordDocTitle; + FreeOnTerminate := True; + OnTerminate := OnThreadTerminate; + FOldOnActivate := Application.OnActivate; + Application.OnActivate := OnAppActivate; + FOldFormChange := Screen.OnActiveFormChange; + Screen.OnActiveFormChange := OnFormChange; + Resume; +end; + +procedure TMSWordThread.WordError; +var + btn: TShow508MessageButton; + msg: string; + + procedure Append(txt: string); + begin + if txt <> '' then + msg := msg + CRLF + txt; + end; + +begin + if FAllowErrorRetry then + btn := smbRetryCancel + else + btn := smbOK; + msg := TX_ERROR_INTRO; + Append(FErrorText1); + if FError.Message <> '' then + Append(FError.Message) + else + Append(TX_NO_DETAILS); + Append(FErrorText2); + FShowingMessage := True; + try + FRetryResult := ShowMsg(Msg, TX_ERROR_TITLE, smiError, btn); + finally + FShowingMessage := False; + end; +end; + +initialization + +finalization + KillSpellCheck; end.