spellers.pas

拼写检查

    destructor Destroy; override;
    function FindMisspell(Buf: PChar; MaxLen: Integer; var Start, Len: Integer): TSpellReturnCode; override;
    function FindNextMisspell(Buf: PChar; MaxLen: Integer; var Start, Len: Integer): TSpellReturnCode; override;
    procedure ChangeOnce(Word, NewWord: String); override;
    procedure ChangeAlways(Word, NewWord: String); override;
    procedure Add(Word: String); override;
    procedure IgnoreAlways(Word: String); override;
    procedure GetVariants(Word: String; Variants: TStrings); override;
    function GetChangeText: String; override;
    function GetMisspellText: String; override;
  public
    Tbl: TConvTable;
  end;  {TISpeller}


type
  THTMLBracket = (thbTag, thbComment, thbBasic);

const
  OpenBracket: array[THTMLBracket] of PChar=('<', '<!--', '<%');
  CloseBracket: array[THTMLBracket] of PChar=('>', '-->', '%>');

var
  ControlTypes: TStrings;

{TSpellChecker}
constructor TSpellChecker.Create(AOwner: TComponent);
begin
  inherited;
  FLanguage:= GetSystemDefaultLCID;
  FOptions:= [spoSuggestFromUserDict, spoIgnoreAllCaps, spoIgnoreMixedDigits,
              spoIgnoreRomanNumerals];
  ActiveLanguage := True;
  FFont := TFont.Create;
  FMissFont := TMisspellFont.Create;
  Spellers:= TList.Create;
  SetFontDefault;
end;

destructor TSpellChecker.Destroy;
var
  I: Integer;
begin
  for I:= Spellers.Count-1 downto 0 do
    TAbstractSpeller(Spellers.Items[I]).Free;
  Spellers.Free;
  FFont.Free;
  FMissFont.Free;
  inherited;
end;

class procedure TSpellChecker.RegisterEditControl(MemoClass: String; Unicode, MultiLanguage: Boolean);
begin
  ControlTypes.AddObject(MemoClass, Pointer(Ord(Unicode) or Ord(MultiLanguage)*2));
end;

procedure TSpellChecker.GetMemoProperties;
var
  C: TClass;
  I: Integer;
begin
  C:= FMemo.ClassType;
  repeat
    for I:= 0 to ControlTypes.Count-1 do
      if AnsiCompareText(C.ClassName, ControlTypes[I])=0 then
        begin
          FLangSupport:= Boolean(Integer(ControlTypes.Objects[I]) shr 1);
          FUnicode:= Boolean(Integer(ControlTypes.Objects[I]) and 1);
          Exit;
        end;
    C:= C.ClassParent;
  until C=TCustomEdit;
  raise ESpellError.CreateFmt('You can''t spell check %s.', [FMemo.Name]);
end;

procedure TSpellChecker.SetLanguage(Value: TLanguage);
begin
  FLanguage:= Value;
end;

function TSpellChecker.OpenLanguage(Value: TLanguage; SpType:
                                    TSpellerType): Boolean;
var
  Speller: TAbstractSpeller;
begin
 Result:= False;
 if SpType = sptMSOffice then begin
   try
     Speller:= TCSAPISpeller.Create(Value, Self, FOptions);
   except
     try
       Speller.Free;
     except end;
     Exit;
   end;
   Spellers.Add(Speller);
   Result:= True;
  end; //if SpellerType = sptMSOffice
 if SpType = sptISpell then begin
   try
     Speller:= TISpeller.Create(Value, Self, FOptions);
   except
     try
       Speller.Free;
     except end;
     Exit;
   end;
   Spellers.Add(Speller);
   Result:= True;
  end; //if SpellerType = sptISpell
end;

function TSpellChecker.FindLanguage(Value: TLanguage; SpType: TSpellerType): TAbstractSpeller;
var
  I: Integer;
begin
  for I:= 0 to Spellers.Count-1 do
    if TAbstractSpeller(Spellers.Items[I]).Language=Value then
      if TAbstractSpeller(Spellers.Items[I]).FSpellerType = SpType
        then begin
          Result:= TAbstractSpeller(Spellers.Items[I]);
          Exit;
        end;
  if OpenLanguage(Value, SpType) then
    Result:= TAbstractSpeller(Spellers.Items[Spellers.Count-1])
  else
    Result:= nil;
end;

function TSpellChecker.IsKnownWord(Word: String; Language: TLanguage): Boolean;
var
  Start, Len: Integer;
begin
  with FindLanguage(Language, SpellerType) do
    Result:= FindMisspell(@Word[1], Length(Word), Start, Len)=srNoErrors;
end;

procedure TSpellChecker.AddWord(Word: String; Language: TLanguage);
begin
  with FindLanguage(Language, SpellerType) do
    Add(Word);
end;

procedure TSpellChecker.GetVariants(Word: String; Variants: TStrings; Language: TLanguage);
begin
  with FindLanguage(Language, SpellerType) do
    GetVariants(Word, Variants);
end;

procedure TSpellChecker.GetTag(From: Integer; var Len: Integer);
var
  P, PP: PChar;
  HTMLTag: THTMLBracket;
  S: String;
begin
  SetLength(S, FSpellEnd-From);
  GetTextRange(@S[1], From, FSpellEnd, 1252);
  if StrLComp(@S[1], OpenBracket[thbComment], StrLen(OpenBracket[thbComment]))=0 then
    HTMLTag:= thbComment
  else if StrLComp(@S[1], OpenBracket[thbBasic], StrLen(OpenBracket[thbBasic]))=0 then
    HTMLTag:= thbBasic
  else
    HTMLTag:= thbTag;
  P:= StrPos(@S[1], CloseBracket[HTMLTag])+StrLen(CloseBracket[HTMLTag]);
  if HTMLTag<>thbBasic then
    begin
      PP:= StrScan(@S[2], '<');
      if (PP<>nil) and (PP<P) then
        begin
          GetTag(PP-@S[1]+From, Len);
          P:= StrPos(PP+Len, CloseBracket[HTMLTag])+StrLen(CloseBracket[HTMLTag]);
        end;
    end;
  if P=nil then
    Len:= Length(S)
  else
    Len:= P-@S[1];
end;

procedure TSpellChecker.GetTextRange(Buf: PChar; StartPos, EndPos: Integer; CP: Word);
type
{ The declarations of TTextRangeA and TTextRangeW in Richedit.pas are incorrect}
  TTextRangeA = record
    chrg: TCharRange;
    lpstrText: PAnsiChar; {not AnsiChar!}
  end;
var
  W: WideString;
  S: String;
  GTL: TGetTextLengthEx;
  GT: TGetTextEx;
  L: Integer;
begin
  GTL.flags:= GTL_DEFAULT;
  GTL.codepage:= 1200;
  L:= FMemo.Perform(EM_GETTEXTLENGTHEX, Integer(@GTL), 0);
  if L>0 then
    begin
      SetLength(W, L);
      GT.cb:= L*2+2;
      GT.flags:= GT_DEFAULT;
      GT.codepage:= 1200;
      GT.lpDefaultChar:= nil;
      GT.lpUsedDefChar:= nil;
      FMemo.Perform(EM_GETTEXTEX, Integer(@GT), Integer(@W[1]));
      WideCharToMultiByte(CP, 0, @W[StartPos+1], EndPos-StartPos, Buf, EndPos-StartPos, nil, nil);
      Buf[EndPos-StartPos]:= #0;
    end
  else
    begin
      S:= FBackMemo.Text;
      StrLCopy(Buf, @S[StartPos+1], EndPos-StartPos);
    end;
end;

function TSpellChecker.GetMemoLanguage: TLanguage;
var
  CF: TCharFormat2A;
  CFW: TCharFormat2W;
begin
  if not FLangSupport then
    Result:= FLanguage
  else if FUnicode then
    begin
      FillChar(CFW, SizeOf(CFW), 0);
      CFW.cbSize:= SizeOf(CFW);
      FBackMemo.Perform(EM_GETCHARFORMAT, 1, LongInt(@CFW));
      Result:= CFW.lid;
    end
  else
    begin
      FillChar(CF, SizeOf(CF), 0);
      CF.cbSize:= SizeOf(CF);
      FBackMemo.Perform(EM_GETCHARFORMAT, 1, LongInt(@CF));
      Result:= CF.lid;
    end;
end;

procedure TSpellChecker.GetBlock(From: Integer; var StartPos, EndPos: Integer);
var
  L, Lang: TLanguage;
  FT: TFindTextA;
  FTW: TFindTextW;
  C: Char;
  P, Len, LP: Integer;
  S: String;
  Pos: PChar;
begin
  P:= From-1;
  repeat
    Inc(P);
    GetTextRange(@C, P, P+1, 1252);
    if FHTML and (C='<') then
      begin
        GetTag(P, Len);
        Inc(P, Len-1);
      end
    else if C=#13 then
      FStartSentence:= True
    else if not (C in [#10, #13, #11]) then
      Break;
  until P>=FSpellEnd;
  if P<FSpellEnd then
    begin
      StartPos:= P;
      if FUnicode then
        begin
          if CRPos<=StartPos then
            begin
              FTW.chrg.cpMin:= StartPos;
              FTW.chrg.cpMax:= FSpellEnd;
              FTW.lpstrText:= #13;
              CRPos:= FBackMemo.Perform(EM_FINDTEXTEX, 1, LongInt(@FTW));
              if CRPos=-1 then
                CRPos:= FSpellEnd;
            end;
          if FHTML then
            if (TagPos<=StartPos) then
              begin
                FTW.chrg.cpMin:= StartPos;
                FTW.chrg.cpMax:= FSpellEnd;
                FTW.lpstrText:= '<';
                TagPos:= FBackMemo.Perform(EM_FINDTEXTEX, 1, LongInt(@FTW));
                if TagPos=-1 then
                  TagPos:= FSpellEnd;
              end
            else
          else
            TagPos:= FSpellEnd;
        end
      else if (FBackMemo is TCustomRichEdit) then
        begin
          if CRPos<=StartPos then
            begin
              FT.chrg.cpMin:= StartPos;
              FT.chrg.cpMax:= FSpellEnd;
              FT.lpstrText:= #13;
              CRPos:= FBackMemo.Perform(EM_FINDTEXT, 1, LongInt(@FT));
              if CRPos=-1 then
                CRPos:= FSpellEnd;
            end;
          if FHTML then
            if (TagPos<=StartPos) then
              begin
                FT.chrg.cpMin:= StartPos;
                FT.chrg.cpMax:= FSpellEnd;
                FT.lpstrText:= '<';
                TagPos:= FBackMemo.Perform(EM_FINDTEXT, 1, LongInt(@FT));
                if TagPos=-1 then
                  TagPos:= FSpellEnd;
              end
            else
          else
            TagPos:= FSpellEnd;
        end
      else
        begin
          S:= FMemo.Text;
          Pos:= StrScan(@S[StartPos+1], #13);
          if Pos<>nil then
            CRPos:= Pos-@S[1]
          else
            CRPos:= FSpellEnd;
          Pos:= StrScan(@S[StartPos+1], '<');
          if Pos<>nil then
            TagPos:= Pos-@S[1]
          else
            TagPos:= FSpellEnd;
        end;
      if FLangSupport then
        if LangPos<=StartPos then
          begin
            FBackMemo.Perform(EM_SETSEL, StartPos, StartPos+1);
            L:= GetMemoLanguage;
            LangPos:= StartPos;
            repeat
              LP:= FBackMemo.Perform(EM_FINDWORDBREAK, WB_RIGHT, LangPos);
              if LP<LangPos then
                Break;
              if (LP=LangPos) and (LP<FSpellEnd) then
                Inc(LP);
              LangPos:= LP;
              FBackMemo.Perform(EM_SETSEL, LangPos, LangPos+1);
              Lang:= GetMemoLanguage;
            until (Lang<>L) or (LangPos>=FSpellEnd);
          end
        else
      else
        LangPos:= FSpellEnd;
      EndPos:= MinIntValue([CRPos, TagPos, LangPos]);
    end
  else
    begin
      StartPos:= FSpellEnd;
      EndPos:= FSpellEnd;
    end;
  if StartPos=0 then
    FStartSentence:= True
  else
    begin
      GetTextRange(@C, StartPos-1, StartPos, 1252);