Corretor Ortográfico

[Marcos Santana]

Colegas montei esse exemplo de corretor com códigos do site Torry's

Está meio bagunçado más está funcionando

Só que se tiver mais de uma palavra para corrigir aparece um caractere estranho tipo quebra de linha onde está atribuindo esse caractere

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Word2000, Psapi, tlhelp32, OleServer, WordXP;

type
  TForm1 = class(TForm)
    Button1: TButton;
    WordApp: TWordApplication;
    WordDoc: TWordDocument;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    function IsSatzZeichen(c: CHAR): Boolean;
    procedure CheckText(Memo: TMemo);
    function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
    function KillTask(ExeFileName: string): Integer;
    function ReplaceStr(Str, SearchStr, ReplaceStr: string): string;
    procedure GetProcessList(var List: TstringList);
    procedure CreateWin9xProcessList(List: TstringList);
    procedure CreateWinNTProcessList(List: TstringList);
  public
    { Public declarations }
  end;


var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

procedure TForm1.CheckText(Memo: TMemo);
var
  i: Integer;
  MySelStart: INTEGER;
  Token: string;
  Line: string;
  ReplaceStr: string;
  WordList: TStrings;
  varFalse: OleVariant;
begin
  // Läuft Word?
  if EXE_Running('WINWORD.EXE', False) then
  begin
    if mrYes = MessageDlg('Word ist geöffnet.' + #13 + #10 +
      'Für die Rechtschreibprüfung muss Word beendet werden.' + #13 + #10 +
      '' + #13 + #10 + 'Word abschiessen?', mtWarning, [mbYes, mbNo], 0) then
    begin
      KillTask('WINWORD.EXE');
    end;
  end
  else
  begin
    // Startwerte
    i := 1;
    Line := Memo.Text;
    WordList := TStringList.Create;
    // Memo traviersieren und einzelne Wörter (Token) rausholen
    while not (Line[i] = #0) do
    begin
      Token := '';
      // Tokem zusammenstellen
      while not IsSatzZeichen(Line[i]) do
      begin
        Token := Token + Line[i];
        Inc(i);
      end;
      if Token <> '' then
      begin
        // Token speichern
        WordList.Add(Token);
      end;
      if IsSatzZeichen(Line[i]) then
      begin
        // "Token" speichern
        WordList.Add(Line[i]);
        Inc(i);
      end;
    end;
    // Verbindung zu Word aufbauen
    WordApp.Disconnect;
    WordDoc.Disconnect;
    WordApp.Connect;
    WordApp.Visible := False;
    // Leeres Dokument erzeugen
    WordDoc.ConnectTo(WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam));
    MySelStart := 0;
    // WordList traversieren und auf Rechschreibung prüfen
    for i := 0 to WordList.Count - 1 do
    begin
      if not IsSatzzeichen(Wordlist[i][1]) then
      begin
        WordApp.Visible := False;
        // WordDokumentinhalt löschen
        WordDoc.Range.Delete(EmptyParam, EmptyParam);
        // Token in Word einfügen
        WordDoc.Range.Set_Text(WordList[i]);
        // Rechtschreibprüfung aufrufen
        WordApp.Visible := False;
        WordDoc.CheckSpelling;
        WordApp.Visible := False;
        // Resultat von der Rechtschreibprüfung holen und aufbereiten
        ReplaceStr := WordDoc.Range.Get_Text;
        WordApp.Visible := False;
       //--- ReplaceStr := ReplaceString(ReplaceStr, #$D, '');
        // Neues Wort in Memo einfügen
        Memo.SetFocus;
        Memo.SelStart := MySelStart;
        Memo.SelLength := Length(WordList[i]);
        Memo.SelText := ReplaceStr;
        WordList[i] := ReplaceStr;
      end;
      MySelStart := MySelStart + Length(WordList[i]);
    end;
    MessageDlg('Correção Ortográfica concluída', mtInformation, [mbOK], 0);
    // Verbindung zu Word abbrechen und Word schliessen ohne zu speichern
    WordDoc.Disconnect;
    WordApp.Disconnect;
    varFalse := False;
    WordApp.Quit(varFalse);
  end;

end;

function TForm1.IsSatzZeichen(c: CHAR): Boolean;
begin
 case c of
    '(': Result := True;
    ')': Result := True;
    ' ': Result := True;
    '.': Result := True;
    ',': Result := True;
    '!': Result := True;
    '?': Result := True;
    '-': Result := True;
    ':': Result := True;
    ';': Result := True;
    #$D: Result := True;
    #$A: Result := True;
    else
      Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CheckText(Memo1);
end;

function TForm1.EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
var
  i: Integer;
  MyProcList: TstringList;
begin
  MyProcList := TStringList.Create;
  try
    GetProcessList(MyProcList);
    Result := False;
    if MyProcList = nil then Exit;
    for i := 0 to MyProcList.Count - 1 do
    begin
      if not bFullpath then
      begin
        if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then
          Result := True
      end
      else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True;
      if Result then Break;
    end;
  finally
    MyProcList.Free;
  end;

end;

function TForm1.KillTask(ExeFileName: string): Integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := 0;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(
                        OpenProcess(PROCESS_TERMINATE,
                                    BOOL(0),
                                    FProcessEntry32.th32ProcessID),
                                    0));
     ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;

procedure TForm1.GetProcessList(var List: TstringList);
var
  ovi: TOSVersionInfo;
begin
  if List = nil then Exit;
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(ovi);
  case ovi.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
    VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
  end
end;

function TForm1.ReplaceStr(Str, SearchStr, ReplaceStr: string): string;
begin
  while Pos(SearchStr, Str) <> 0 do
  begin
    Insert(ReplaceStr, Str, Pos(SearchStr, Str));
    Delete(Str, Pos(SearchStr, Str), Length(SearchStr));
  end;
  Result := Str;
end;

procedure TForm1.CreateWin9xProcessList(List: TstringList);
var
  hSnapShot: THandle;
  ProcInfo: TProcessEntry32;
begin
  if List = nil then Exit;
  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapShot <> THandle(-1)) then
  begin
    ProcInfo.dwSize := SizeOf(ProcInfo);
    if (Process32First(hSnapshot, ProcInfo)) then
    begin
      List.Add(ProcInfo.szExeFile);
      while (Process32Next(hSnapShot, ProcInfo)) do
        List.Add(ProcInfo.szExeFile);
    end;
    CloseHandle(hSnapShot);
  end;
end;

procedure TForm1.CreateWinNTProcessList(List: TstringList);
var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I: Integer;
  ProcCount: Integer;
  hMod: HMODULE;
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
begin
  if List = nil then Exit;
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
      List.Add(ModuleName);
      CloseHandle(hProcess);
    end;
  end;
end;

end.

[Micheus]

Marcos Santana, avaliar a situação, implicaria em implementar o código e depurá-lo e eu pelo menos não poderia ajudá-lo agora.

Mas, deixo aqui uma sugestão de outra rotina em que inclusive é muito similar a do word, visto que mostra ao usuário as sugestões de alterações, e ao meu ver melhor codificada: Spell Checking from Delphi code using MS Word (ref. About.com - site muito bom) - o projeto pode ser baixado na última parte do tutorial.

Para quem quiser testar, há no site Delphi3000 um componente que faz uso do mesmo recurso: VCL MS Word Spell Check and Thesaurus

OBS: Se precisar traduzir as mensagens do Alemão para Inglês (e depois para o Português), você pode usar o AltaVista - Babel Fish.

Abraços