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

Previous  Top  Next

    
 

 

 

 

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

 

Code:

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 ).

 

©Drkb::00148

       

Взято с http://delphiworld.narod.ru

 


Code:

{ **** 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, separator@mail.kz, Алматы

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

 

 

©Drkb::00876

 


 

 

Code:

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Разбиение текста на слова + получение количества слов в тексте

 

T : Собственно строка, которая будет разбиваться на слова

Mode: Режим, может быть

0: получение английских и русских слов

1: только русских

2: только английских

List: Здесь хранятся найденые слова (по умолчанию = nil)

 

возвращаемое значение: количество слов.

 

P/S

По идейным соображениям специальные символы, цифры

и пробелы игнорируются.

 

Зависимости: Windows, Classes

Автор:       777, nix@rbcmail.ru, Архангельск

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;

 

 

 

©Drkb::00877

 


 

Code:

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;

 

©Drkb::00878

Взято с сайта: http://www.swissdelphicenter.ch

 

 


 

Расщепить строку в слова и обратно

Code:

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.

 

 

©Drkb::00879

http://delphiworld.narod.ru/

DelphiWorld 6.0