| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Поиск email в тексте TMemo [D7]

4ubaka ©   (2005-06-11 13:20:00) 

Добрый день. Пишу программу, которая умеет выделять(находить) все адреса email в тексте TMemo.
Написал алгоритм, который находит положение @ в тексте, а потом копирует по одному символу с каждой стороны от @ пока не встретиться пробел или кавычки. Но он не работает.
Может кто-то сталкивался с подобной задачей? Помогите! Можно на email: kev89@mail.ru

---

Николай,герм   (2005-06-12 19:30:00) [1]

у меня есть другой варант :
только коментов мало .

procedure TForm1.BitBtn1Click(Sender: TObject);
var
mail, text, affeN:string;
k ,i,anzh,voranzh: integer;
begin
k:=0;
affeN:='';
text := RichEdit1.Text;
for i:=0 to Length(text) do
begin

  if ('@'= Copy(text,i-1,1)) then
   begin
     k:=k+1;
     BitBtn1.Caption:= IntToStr(k);
     anzh:=0;
   // Найти после  @
    repeat
      anzh:=anzh+1;
    until ('"'= Copy(text,i+anzh,1));

  // Найти до @
    voranzh:=i;
    repeat
      voranzh:=voranzh-1;
    until (':'= Copy(text,voranzh,1));

    affeN:= Copy(text,voranzh+1,(i-voranzh+anzh-1))+ ' ';
    voranzh:=0;
    mail := mail + affeN;
    affeN:='';
   end;
end;
 Richedit2.Lines.Add(mail) ;

 BitBtn1.Caption:= 'Finden mails und anzeigen  mails adressen gefunden Anzahl : ' + IntToStr(k);
 RichEdit1.Clear;
end;


моэет кому поможет.

---

Николай,гер   (2005-06-12 14:27:00) [2]

Удалено модератором
Примечание: Ник измени

---

iskatel   (2005-06-11 19:48:00) [3]

зря ты так - использовать их не сложно, особенно TRegExp, зато вытащит наверняка, и на всякие левые @ не среагирует...

---

TUser   (2005-06-11 18:59:00) [4]

> iskatel ©   (11.06.05 18:29) [7]

Регулярными выражениями адреса вытаскивать - это как из пушки по воробьям.

---

iskatel   (2005-06-11 18:29:00) [5]

короче тебе прямая дорога regexp - ы изучать, они тебе помогут, можешь попробовать TRegExp, но он слабоват, покруче будет VbScript Regular Expression - ставится вместе с оффисом, но можно отдельно dll  перетащить - но придется юзать COM

---

4ubaka   (2005-06-11 17:05:00) [6]

Удалено модератором

---

TUser   (2005-06-11 13:53:00) [7]

Что-то вроде этого, только учти, что этот подход ни в коем случае не является универсальным. Например, существуют концы строки и другие символы, которые никак не могут быть в составе адреса.

procedure FindAddressesInMemo (SL: TStrings);
var i: integer;
   start, finish: integer;
   state: smallint;

procedure Proceed (C: char);
begin
   case C of
     ' ', '"':
      begin
        if state = 3 then
          SL.Add(copy(Memo1.Lines,Text,start,finish-start+1));
        state:=0;
      end;
     '@':
      if state = 1 then begin        
        inc (finish); state:=2;
        end;
     else
      begin
        if state = 0 then begin
          state:=1; start:=i; finish:=i-1;
          end else
        if state = 2 then
          state = 3;
        inc (finish);
      end;
     end;

end;

begin
 state:=0;
 for i:=1 to length(Memo1.Lines.Text) do
   Proceed(Memo1.Lines.Text[i]);
 Proceed(' ');
end;

---

-=XP=-   (2005-06-11 13:50:00) [8]

SPAMERS MUST DIE

---

4ubaka   (2005-06-11 13:31:00) [9]

Ошибка как раз не вылазит, вообще ничего не вылазит.
И я не спамер.

procedure TForm1.emailerExecute(Sender: TObject);
var
i,n:integer;
s:string;
begin
n:=length(memo1.Text);
while i < n do
begin
 i:=pos('@',memo1.Text);
 CheckListBox1.Items.Insert(0,DetectAddress(i));
end;
end;

function TForm1.DetectAddress(posn: integer): string;
var
start,fin,s,f:string;
d,n,i:integer;
begin
 for i:=0 to 100 do
  begin
    f:=copy(memo1.Text,posn-i,1);
     while not (f=' ') do
      begin
        start:=f+start;
      end;
      if f=' ' then
      break;
  end;

  for i:=0 to 100 do
   begin
     f:=copy(memo1.Text,posn+i,1);
      while not (f='"') or not (f=' ') do
       begin
        fin:=f+fin;
       end;
       if (f='"') or (f=' ') then
       break;
    end;
    result:=start+'@'+fin;
end;

---

Homa_Programer   (2005-06-11 13:29:00) [10]

а что за ошибка то вылазит? в чем проблема... вроде смысл правильный... а вот как реализовано у тебя?!

---

TUser   (2005-06-11 13:23:00) [11]

> Написал алгоритм, который находит положение @ в тексте, а потом копирует по одному символу с каждой стороны от @ пока не встретиться пробел или кавычки. Но он не работает.

Выделенные жирным слова противоречат друг другу. А вообще - спамерам - бой!

---

Наверх