Разбивка строки на слова

=== Разбивка строки на слова ===
Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных. 
function GetToken(aString, SepChar: string; TokenNum: Byte): string;
{
параметры: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
TokenNum: номер требуемого слова (подстроки))
result : искомое слово или пустая строка, если количество слов
меньше значения 'TokenNum'
}
var
 Token: string;
 StrLen: Byte;
 TNum: Byte;
 TEnd: Byte;
begin
 StrLen := Length(aString);
 TNum := 1;
 TEnd := StrLen;
 while ((TNum <= TokenNum) and (TEnd <> 0)) do
 begin
 TEnd := Pos(SepChar, aString);
 if TEnd <> 0 then
 begin
 Token := Copy(aString, 1, TEnd - 1);
 Delete(aString, 1, TEnd);
 Inc(TNum);
 end
 else
 begin
 Token := aString;
 end;
 end;
 if TNum >= TokenNum then
 begin
 GetToken1 := Token;
 end
 else
 begin
 GetToken1 := ;
 end;
end;
function NumToken(aString, SepChar: string): Byte;
{
parameters: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
result : количество найденных слов (подстрок)
}
var
 RChar: Char;
 StrLen: Byte;
 TNum: Byte;
 TEnd: Byte;
begin
 if SepChar = '#' then
 begin
 RChar := '*'
 end
 else
 begin
 RChar := '#'
 end;
 StrLen := Length(aString);
 TNum := 0;
 TEnd := StrLen;
 while TEnd <> 0 do
 begin
 Inc(TNum);
 TEnd := Pos(SepChar, aString);
 if TEnd <> 0 then
 begin
 aString[TEnd] := RChar;
 end;
 end;
 Result := TNum;
end;
// Или другое решение:
function CopyColumn(const s_string: string; c_fence: char;
 i_index: integer): string;
var
 i, i_left: integer;
begin
 result := EmptyStr;
 if i_index = 0 then
 begin
 exit;
 end;
 i_left := 0;
 for i := 1 to Length(s_string) do
 begin
 if s_string[i] = c_fence then
 begin
 Dec(i_index);
 if i_index = 0 then
 begin
 result := Copy(s_string, i_left + 1, i - i_left - 1);
 exit;
 end
 else
 begin
 i_left := i;
 end;
 end;
 end;
 Dec(i_index);
 if i_index = 0 then
 begin
 result := Copy(s_string, i_left + 1, Length(s_string));
 end;
end;
Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту не сработает. ( Delete(aString, 1, TEnd) будет ошибкой, если Length( SepChar ) > 1 ). 
Source: Взято с http://delphiworld.narod.ru
ID: 00148
----
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Разбивка строки на отдельные слова
function StringToWords(const DelimitedText: string; ResultList: TStrings;
Delimiters: TDelimiter = []): boolean - разбивает отдельную строку на
состовляющие ее слова и результат помещает в TStringList
function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;
Delimiters: TDelimiter = []): boolean - разбивает любое количество строк на
состовляющие их слова и все помещяет в один TStringList
Delimiters - список символов являющихся разделителями слов,
например такие как пробел, !, ? и т.д.
Зависимости: Classes
Copyright: Separator
Дата: 13 ноября 2002 г.
***************************************************** }
unit spUtils;
interface
uses Classes;
type
 TDelimiter = set of #0..'я' ;
const
 StandartDelimiters: TDelimiter = [' ', '!', '@', '(', ')', '-', '|', '\', ';',
 ':', '"', '/', '?', '.', '>', ',', '<'];
 //Преобразование в набор слов
function StringToWords(const DelimitedText: string; ResultList: TStrings;
 Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;
function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;
 Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;
implementation
function StringToWords(const DelimitedText: string; ResultList: TStrings;
 Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;
var
 i, Len, Prev: word;
 TempList: TStringList;
begin
 Result := false;
 if (ResultList <> nil) and (DelimitedText <> ) then
 try
 TempList := TStringList.Create;
 if Delimiters = [] then
 Delimiters := StandartDelimiters;
 Len := 1;
 Prev := 0;
 for i := 1 to Length(DelimitedText) do
 begin
 if Prev <> 0 then
 begin
 if DelimitedText[i] in Delimiters then
 begin
 if Len = 0 then
 Prev := i + 1
 else
 begin
 TempList.Add(copy(DelimitedText, Prev, Len));
 Len := 0;
 Prev := i + 1
 end
 end
 else
 Inc(Len)
 end
 else if not (DelimitedText[i] in Delimiters) then
 Prev := i
 end;
 if Len > 0 then
 TempList.Add(copy(DelimitedText, Prev, Len));
 if TempList.Count > 0 then
 begin
 if ListClear then
 ResultList.Assign(TempList)
 else
 ResultList.AddStrings(TempList);
 Result := true
 end;
 finally
 TempList.Free
 end
end;
function StringsToWords(const DelimitedStrings: TStrings; ResultList: TStrings;
 Delimiters: TDelimiter = []; ListClear: boolean = true): boolean;
begin
 if Delimiters = [] then
 Delimiters := StandartDelimiters + [#13, #10]
 else
 Delimiters := Delimiters + [#13, #10];
 Result := StringToWords(DelimitedStrings.Text, ResultList, Delimiters,
 ListClear)
end;
end.
//Пример использования: 
StringToWords(Edit1.Text, Memo1.Lines);
StringToWords(Edit1.Text, Memo1.Lines, [' ', '.', ',']);
StringsToWords(Memo1.Lines, Memo2.Lines);
StringsToWords(Memo1.Lines, Memo2.Lines, [' ', '.', ',']); 
Source: delphibase.endimus.com
ID: 00876
----
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Разбиение текста на слова + получение количества слов в тексте
T : Собственно строка, которая будет разбиваться на слова
Mode: Режим, может быть
0: получение английских и русских слов
1: только русских
2: только английских
List: Здесь хранятся найденые слова (по умолчанию = nil)
возвращаемое значение: количество слов.
P/S
По идейным соображениям специальные символы, цифры
и пробелы игнорируются.
Зависимости: Windows, Classes
Copyright: 777
Дата: 15 июня 2002 г.
***************************************************** }
function StringToWords(T: string; Mode: Short; List: Tstrings = nil): integer;
var
 i, z: integer;
 s: string;
 c: Char;
 procedure Check;
 begin
 if (s > ) and (List <> nil) then
 begin
 List.Add(S);
 z := z + 1;
 end;
 s := ;
 end;
begin
 i := 0;
 z := 0;
 s := ;
 if t > then
 begin
 while i <= Length(t) + 1 do
 begin
 c := t[i];
 case Mode of
 0: {русские и английские слова}
 if (c in ['a'..'z']) or (c in ['A'..'Z']) or (c in ['а'..'я']) or
 (c in ['А'..'Я']) and (c <> ' ') then
 s := s + c
 else
 Check;
 1: {только русские слова}
 if (c in ['а'..'я']) or (c in ['А'..'Я']) and (c <> ' ') then
 s := s + c
 else
 Check;
 2: {только английские слова}
 if (c in ['a'..'z']) or (c in ['A'..'Z']) and (c <> ' ') then
 s := s + c
 else
 check;
 end;
 i := i + 1;
 end;
 end;
 result := z;
end;
//Пример использования: 
procedure TForm1.Button1Click(Sender: TObject);
var
 Source, Dest: Tstrings;
 i: integer;
begin
 Source := TstringList.Create;
 Dest := TstringList.Create;
 Source.LoadFromFile('c:\MyText.txt');
 for i := 0 to Source.Count - 1 do
 begin
 StringToWords(Source[i], 2, Dest);
 Application.ProcessMessages;
 end;
 Dest.SaveToFile('c:\MyWords.txt');
 ShowMessage('Найдено ' + IntToStr(Dest.Count) + ' слов');
end;
Source: delphibase.endimus.com
ID: 00877
----
procedure SplitTextIntoWords(const S: string; words: TstringList);
 var
 startpos, endpos: Integer;
 begin
 Assert(Assigned(words));
 words.Clear;
 startpos := 1;
 while startpos <= Length(S) do
 begin
 // skip non-letters 
 while (startpos <= Length(S)) and not IsCharAlpha(S[startpos]) do
 Inc(startpos);
 if startpos <= Length(S) then
 begin
 // find next non-letter 
 endpos := startpos + 1;
 while (endpos <= Length(S)) and IsCharAlpha(S[endpos]) do
 Inc(endpos);
 words.Add(Copy(S, startpos, endpos - startpos));
 startpos := endpos + 1;
 end; { If }
 end; { While }
 end; { SplitTextIntoWords }
 function StringMatchesMask(S, mask: string;
 case_sensitive: Boolean): Boolean;
 var
 sIndex, maskIndex: Integer;
 begin
 if not case_sensitive then
 begin
 S := AnsiUpperCase(S);
 mask := AnsiUpperCase(mask);
 end; { If }
 Result := True; // blatant optimism 
 sIndex := 1;
 maskIndex := 1;
 while (sIndex <= Length(S)) and (maskIndex <= Length(mask)) do
 begin
 case mask[maskIndex] of
 '?':
 begin
 // matches any character 
 Inc(sIndex);
 Inc(maskIndex);
 end; { case '?' }
 '*':
 begin
 // matches 0 or more characters, so need to check for 
 // next character in mask 
 Inc(maskIndex);
 if maskIndex > Length(mask) then
 // * at end matches rest of string 
 Exit
 else if mask[maskindex] in ['*', '?'] then
 raise Exception.Create('Invalid mask');
 // look for mask character in S 
 while (sIndex <= Length(S)) and
 (S[sIndex] <> mask[maskIndex]) do
 Inc(sIndex);
 if sIndex > Length(S) then
 begin
 // character not found, no match 
 Result := False;
 Exit;
 end;
 { If }
 end; { Case '*' }
 else if S[sIndex] = mask[maskIndex] then
 begin
 Inc(sIndex);
 Inc(maskIndex);
 end { If }
 else
 begin
 // no match 
 Result := False;
 Exit;
 end;
 end; { Case }
 end; { While }
 // if we have reached the end of both S and mask we have a complete 
 // match, otherwise we only have a partial match 
 if (sIndex <= Length(S)) or (maskIndex <= Length(mask)) then
 Result := False;
 end; { stringMatchesMask }
 procedure FindMatchingWords(const S, mask: string;
 case_sensitive: Boolean; matches: Tstrings);
 var
 words: TstringList;
 i: Integer;
 begin
 Assert(Assigned(matches));
 words := TstringList.Create;
 try
 SplitTextIntoWords(S, words);
 matches.Clear;
 for i := 0 to words.Count - 1 do
 begin
 if stringMatchesMask(words[i], mask, case_sensitive) then
 matches.Add(words[i]);
 end; { For }
 finally
 words.Free;
 end;
 end;
 { 
 The Form has one TMemo for the text to check, one TEdit for the mask, 
 one TCheckbox (check = case sensitive), one TListbox for the results, 
 one Tbutton 
}
 procedure TForm1.Button1Click(Sender: TObject);
 begin
 FindMatchingWords(memo1.Text, edit1.Text, checkbox1.Checked, listbox1.Items);
 end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00878
----
Расщепить строку в слова и обратно 
unit StrFuncs;
interface 
uses SysUtils, Classes; 
function StrToArrays(str, r: string; out temp: TStrings): Boolean; 
function ArrayToStr(str: TStrings; r: string): string; 
implementation 
function StrToArrays(str, r: string; out temp: TStrings): Boolean; 
var 
 j: Integer; 
begin 
 if temp <> nil then 
 begin 
 temp.Clear; 
 while str <> do 
 begin 
 j := Pos(r, str); 
 if j = 0 then j := Length(str) + 1; 
 temp.Add(Copy(Str, 1, j - 1)); 
 Delete(Str, 1, j + Length(r) - 1); 
 end; 
 Result := True; 
 else 
 Result := False; 
 end; 
end; 
function ArrayToStr(str: TStrings; r: string): string; 
var 
 i: Integer; 
begin 
 Result := ; 
 for i := 0 to Str.Count - 1 do 
 begin 
 Result := Result + Str.Strings[i] + r; 
 end; 
end; 
end.
Source: http://delphiworld.narod.ru/
ID: 00879