Поиск емайлов в тексте

[hkdkest]

Подскажите как проще найти все емайлы в тексте? Может есть написанная процедурка для этого?

[artemavd]

Вот несколько интересных процедурок поиска. Посмотри, может какая-нибудь пригодится:

Поиск строки текста в наследниках TCustomEdit 

В опции поиска можно подключать, отключать, комбинировать следующие
параметры:
frDown - указывает на то, что происходит поиск вниз по тексту от курсора(при
отключенном frDown'е будет происходит поиск вверх по тексту).
frMatchCase - указывает на то, что следует проводить поиск с учетом
регистра.
frWholeWord - указывает на то, что следует искать только слово целиком.

unit Search;

interface

uses

  WinProcs, SysUtils, StdCtrls, Dialogs;

const

  WordDelimiters: set of Char = [#0..#255] - ['a'..'z', 'A'..'Z', '1'..'9',
    '0'];
 function SearchMemo(Memo: TCustomEdit;

  const SearchString: string;
  Options: TFindOptions): Boolean;

function SearchBuf(Buf: PChar; BufLen: Integer;

  SelStart, SelLength: Integer;
  SearchString: string;
  Options: TFindOptions): PChar;

implementation

function SearchMemo(Memo: TCustomEdit;

  const SearchString: string;
  Options: TFindOptions): Boolean;
var

  Buffer, P: PChar;
  Size: Word;
begin

  Result := False;
  if (Length(SearchString) = 0) then
    Exit;
  Size := Memo.GetTextLen;
  if Size = 0 then
    Exit;
  Buffer := StrAlloc(Size + 1);
  try
    Memo.GetTextBuf(Buffer, Size + 1);
    P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength, SearchString,
      Options);
    if P <> nil then
    begin
      Memo.SelStart := P - Buffer;
      Memo.SelLength := Length(SearchString);
      Result := True;
    end;
  finally
    StrDispose(Buffer);
  end;
end;

function SearchBuf(Buf: PChar; BufLen: Integer;

  SelStart, SelLength: Integer;
  SearchString: string;
  Options: TFindOptions): PChar;
var

  SearchCount, I: Integer;
  C: Char;
  Direction: Shortint;
  CharMap: array[Char] of Char;

  function FindNextWordStart(var BufPtr: PChar): Boolean;
  begin { (True XOR N) is equivalent to (not N) }
    //    Result := False;      { (False XOR N) is equivalent to (N)    }

    { When Direction is forward (1), skip non delimiters, then skip delimiters. }
    { When Direction is backward (-1), skip delims, then skip non delims }

    while (SearchCount > 0) and
      ((Direction = 1) xor
      (BufPtr^ in WordDelimiters)) do
    begin
      Inc(BufPtr, Direction);
      Dec(SearchCount);
    end;

    while (SearchCount > 0) and
      ((Direction = -1) xor
      (BufPtr^ in WordDelimiters)) do
    begin
      Inc(BufPtr, Direction);
      Dec(SearchCount);
    end;

    Result := SearchCount > 0;
    if Direction = -1 then
    begin {back up one char, to leave ptr on first non delim}
      Dec(BufPtr, Direction);
      Inc(SearchCount);
    end;
  end;

begin

  Result := nil;

  if BufLen <= 0 then
    Exit;

  if frDown in Options then
  begin {if frDown...}
    Direction := 1;
    Inc(SelStart, SelLength); { start search past end of selection }
    SearchCount := BufLen - SelStart - Length(SearchString);

    if SearchCount < 0 then
      Exit;

    if Longint(SelStart) + SearchCount > BufLen then
      Exit;

  end {if frDown...}
  else
  begin {else}
    Direction := -1;
    Dec(SelStart, Length(SearchString));
    SearchCount := SelStart;
  end; {else}

  if (SelStart < 0) or (SelStart > BufLen) then
    Exit;

  Result := @Buf[SelStart];
  { Using a Char map array is faster than calling AnsiUpper on every character }

  for C := Low(CharMap) to High(CharMap) do
    CharMap[C] := C;

  if not (frMatchCase in Options) then
  begin {if not (frMatchCase}
    AnsiUpperBuff(PChar(@CharMap), sizeof(CharMap));
    AnsiUpperBuff(@SearchString[1], Length(SearchString));
  end; {if not (frMatchCase}

  while SearchCount > 0 do
  begin {while SearchCount}
    if frWholeWord in Options then
    begin
      if not FindNextWordStart(Result) then
        Break;
    end;
    I := 0;

    while (CharMap[Result[I]] = SearchString[I + 1]) do
    begin {while (CharMap...}
      Inc(I);
      if I >= Length(SearchString) then
      begin {if I >=...}
        if (not (frWholeWord in Options)) or
          (SearchCount = 0) or
          (Result[I] in WordDelimiters) then
          Exit;
        Break;
      end; {if I >=...}
    end; {while (CharMap...}

    Inc(Result, Direction);
    Dec(SearchCount);
  end; {while SearchCount}

  Result := nil;
end;

end.

Или этот:

function Find(const S, P: string): Integer;
var
  i, j: Integer;
begin
  Result := 0;
  if Length(P) > Length(S) then
    Exit;
  for i := 1 to Length(S) - Length(P) + 1 do
    for j := 1 to Length(P) do
      if P[j] <> S[i + j - 1] then
        Break
      else if j = Length(P) then
      begin
        Result := i;
        Exit;
      end;
end;

[BOBAH13]

Незнаю что вы имели ввиду под столь огромным кодом но вот делать нечего решил сделать )) больше времени ушло компоненты покидать на форму чем код написать

[hkdkest]

Сообщение от BOBAH13

Незнаю что вы имели ввиду под столь огромным кодом но вот делать нечего решил сделать )) больше времени ушло компоненты покидать на форму чем код написать

Спс, это подойдет