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;

{ **** 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

Автор: Separator, <a href="mailto:separator@mail.kz">separator@mail.kz</a>, Алматы

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, [' ', '.', ',']);

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Разбиение текста на слова + получение количества слов в тексте
T : Собственно строка, которая будет разбиваться на слова
Mode: Режим, может быть
0: получение английских и русских слов
1: только русских
2: только английских
List: Здесь хранятся найденые слова (по умолчанию = nil)
возвращаемое значение: количество слов.
P/S
По идейным соображениям специальные символы, цифры
и пробелы игнорируются.
Зависимости: Windows, Classes
Автор: 777, <a href="mailto:nix@rbcmail.ru">nix@rbcmail.ru</a>, Архангельск
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;

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;

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.