Часто юзаю эту функцию из FAQа, предлагаю общими усилиями ее освежить и усовершенствовать, сделать "идеальный" вариант.
Мой новый вариант такой:

Код

Function isEmail(txt As String) As Boolean Dim Host As String, arrHost() As String, i As Integer, temp() As String 'доменные имена, список можно пополнять без изменения кода Host = "com|org|net|edu|gov|mil|int|af|al|dz|as|ad|ao|ai|aq|ag|ar|am|aw|" & _ "ac|au|at|az|bs|bh|bd|bb|by|bz|bt|bj|bbe|bm|bo|ba|bw|bv|br|io|bn|bg|bf|bi|" & _ "kh|cm|ca|cv|ky|cf|td|cl|cn|cx|cc|co|km|cd|cg|ck|cr|ci|hr|cu|cy|cz|dk|dj|dm|" & _ "do|tp|ec|eg|sv|gq|er|ee|et|fk|fo|fj|fi|fr|gf|pf|tf|ga|gm|ge|de|gh|gi|gr|gl|gd|" & _ "gp|gu|gt|gg|gn|gw|gy|ht|hm|va|hn|hk|hu|is|in|id|ir|iq|ie|im|il|it|jm|jp|je|jo|" & _ "kz|ke|ki|kp|kr|kw|kg|la|lv|lb|ls|lr|ly|li|lt|lu|mo|mk|mg|mw|my|mv|ml|mt|mh|mq|" & _ "mr|mu|yt|mx|fm|md|mc|mn|ms|ma|mz|mm|na|nr|np|nl|an|nc|nz|ni|ne|ng|nu|nf|mp|no|" & _ "om|pk|pw|pa|pg|py|pe|ph|pn|pl|pt|pr|qa|re|ro|ru|rw|kn|lc|vc|ws|sm|st|sa|sn|sc|" & _ "sl|sg|sk|si|sb|so|za|gs|es|lk|sh|pm|sd|sr|sj|sz|se|ch|sy|tw|tj|tz|th|tg|tk|to|" & _ "tt|tn|tr|tm|tc|tv|ug|ua|ae|gb|us|um|uy|uz|vu|ve|vn|vg|vi|wf|eh|ye|yu|zr|zm|zw|uk|su" arrHost = Split(Host, "|") 'вырезаем теги, если есть, и все что снаружи их, так как они в проверке не учавствуют If InStr(1, txt, "mailto:", vbTextCompare) Then txt = Right(txt, Len(txt) - (InStr(txt, ":"))) If InStr(txt, "<") Then txt = Right(txt, Len(txt) - (InStr(txt, "<"))) If InStr(txt, ">") Then txt = Left(txt, InStr(txt, ">") - 1) If InStr(txt, "?") Then txt = Left(txt, InStr(txt, "?") - 1) 'проверка на только разрешенные символы     For i = 1 To Len(txt)         If InStr(1, "qwertyuiopasdfghjklzxcvbnm1234567890@_.<> ", Mid(txt, i, 1), vbTextCompare) = 0 Then isEmail = False: Exit Function     Next i 'грубая проверка на соответствие маске, min длине имени домена(=2),min длине имени юзера (=1) If Trim(txt) Like "*?@??*.??*" Then isEmail = True Else isEmail = False: Exit Function 'только 1 "собака" temp = Split(LCase(txt), "@") If UBound(temp) > 1 Then isEmail = False: Exit Function 'только 1 точка temp = Split(LCase(txt), ".") If UBound(temp) > 1 Then isEmail = False: Exit Function 'проверка на валидность доменного имени isEmail = False     For i = 0 To UBound(arrHost)         If temp(1) = arrHost(i) Then isEmail = True: Exit For     Next i End Function

Функция какая-то кривая, аднака...
1) адрес не обязан предваряться mailto:
2) точек в адресе может быть куча, причем как до, так и после собаки
3) адрес не обязан быть глобальным
4) откуда взялись теги?

Akina

Цитата

кривая, аднака

Согласен, хочу сделать прямую, затем и запостил.
1. mailto: вырезается перед проверкой, но наличие этой команды перед мылом не является ошибкой.
2. Этого не знал, гут, сенкс, исправим...
3. При необходимости можно добавить в список локальные домены.
4. Строка вида "Name<[email protected]>?Subject=Тема&body=Текст". Цель этой функции - правильно распознать в строке, введенной в твоей программе юзером email адрес для дальнейшей передачи строки API функции "ShellExecuteA" библиотеки shell32.dll. Если в строке есть дополнительные данные, такие как имя, тема сообщения, текст сообщения, то в открывшемся дефолтном почтовике они попадут в свои окна.

Код

Function isEmail(txt As String) As Boolean Dim Host As String, arrHost() As String, i As Integer, temp() As String 'доменные имена, список можно пополнять без изменения кода Host = "com|org|net|edu|gov|mil|int|af|al|dz|as|ad|ao|ai|aq|ag|ar|am|aw|" & _ "ac|au|at|az|bs|bh|bd|bb|by|bz|bt|bj|bbe|bm|bo|ba|bw|bv|br|io|bn|bg|bf|bi|" & _ "kh|cm|ca|cv|ky|cf|td|cl|cn|cx|cc|co|km|cd|cg|ck|cr|ci|hr|cu|cy|cz|dk|dj|dm|" & _ "do|tp|ec|eg|sv|gq|er|ee|et|fk|fo|fj|fi|fr|gf|pf|tf|ga|gm|ge|de|gh|gi|gr|gl|gd|" & _ "gp|gu|gt|gg|gn|gw|gy|ht|hm|va|hn|hk|hu|is|in|id|ir|iq|ie|im|il|it|jm|jp|je|jo|" & _ "kz|ke|ki|kp|kr|kw|kg|la|lv|lb|ls|lr|ly|li|lt|lu|mo|mk|mg|mw|my|mv|ml|mt|mh|mq|" & _ "mr|mu|yt|mx|fm|md|mc|mn|ms|ma|mz|mm|na|nr|np|nl|an|nc|nz|ni|ne|ng|nu|nf|mp|no|" & _ "om|pk|pw|pa|pg|py|pe|ph|pn|pl|pt|pr|qa|re|ro|ru|rw|kn|lc|vc|ws|sm|st|sa|sn|sc|" & _ "sl|sg|sk|si|sb|so|za|gs|es|lk|sh|pm|sd|sr|sj|sz|se|ch|sy|tw|tj|tz|th|tg|tk|to|" & _ "tt|tn|tr|tm|tc|tv|ug|ua|ae|gb|us|um|uy|uz|vu|ve|vn|vg|vi|wf|eh|ye|yu|zr|zm|zw|uk|su" arrHost = Split(Host, "|") 'вырезаем теги, если есть, и все что снаружи их, так как они в проверке не учавствуют If InStr(1, txt, "mailto:", vbTextCompare) Then txt = Right(txt, Len(txt) - (InStr(txt, ":"))) If InStr(txt, "<") Then txt = Right(txt, Len(txt) - (InStr(txt, "<"))) If InStr(txt, ">") Then txt = Left(txt, InStr(txt, ">") - 1) If InStr(txt, "?") Then txt = Left(txt, InStr(txt, "?") - 1) 'проверка на только разрешенные символы     For i = 1 To Len(txt)         If InStr(1, "qwertyuiopasdfghjklzxcvbnm1234567890@_. ", Mid(txt, i, 1), vbTextCompare) = 0 Then isEmail = False: Exit Function     Next i 'только 1 "собака", min длина имени домена=2, min длина имени юзера=1 temp = Split(LCase(txt), "@") If UBound(temp) = 1 Then     If Trim(temp(0)) = "" Or Trim(temp(1)) = "" Or (InStr(txt, ".") - InStr(txt, "@")) <= 2 Then isEmail = False: Exit Function     Else     isEmail = False: Exit Function End If 'проверка на валидность доменного имени temp(1) = Right(txt, Len(txt) - InStrrev(txt, ".")) isEmail = False     For i = 0 To UBound(arrHost)         If temp(1) = arrHost(i) Then isEmail = True: Exit For     Next i End Function

Это сообщение отредактировал(а) bom - 13.7.2005, 14:47

Вот например канва для выделения адресов (причем их может быть в строке несколько).

Код

Option Base 0 Private Const ValidChars As String = "qwertyuiopasdfghjklzxcvbnm1234567890@_." Sub ParseMailAddresses(StringToParse As String, Addresses() As String) Dim Tmp() As String Dim Temp1 As String Dim Temp2 As String Dim i As Integer Tmp = Split(Trim(StringToParse), "@") If UBound(Tmp) < 1 Then     ReDim Addresses(0)     Exit Sub End If ReDim Addresses(UBound(Tmp) - 1) For i = 0 To UBound(Tmp) - 1     Temp1 = ""     Temp2 = ""     Do While Len(Tmp(i)) > 0         If InStr(ValidChars, Right(Tmp(i), 1)) > 0 Then             Temp1 = Right(Tmp(i), 1) & Temp1             Tmp(i) = Left(Tmp(i), Len(Tmp(i)) - 1)         Else             Exit Do         End If     Loop     Do While Len(Tmp(i + 1)) > 0         If InStr(ValidChars, Left(Tmp(i + 1), 1)) > 0 Then             Temp2 = Temp2 & Left(Tmp(i + 1), 1)             Tmp(i + 1) = Mid(Tmp(i + 1), 2)         Else             Exit Do         End If     Loop     Addresses(i) = Temp1 & "@" & Temp2 Next i End Sub

Однако все много сложнее... в адресе могут быть почти любые символы, в т.ч. и пробелы (см. напр. RFC 822)... вот, скажем, совершенно валидный адрес: "John Smith"@domain.com

Akina

Цитата

все много сложнее...

Благодарю Akina за разъяснение, попробую поискать дополнительную инфу по этому вопросу. А что это за RFC 822?

На всякий случай скажу, что в FAQ'e должна быть функция, которая определяет (насколько хорошо не знаю) есть ли в строке почтовый адрес:
VB-VB-002147

Просто для сведения...
Добавлено @ 22:23
Только что заметил, что это bom и написал...

bom
http://www.faqs.org/rfcs/index.html

Цитата(cardinal @ 13.7.2005, 23:23)

(насколько хорошо не знаю)

Собсно именно об этот моменте речь...

А я для себя софтинку сделал - по проще вроде ваших изысков - пользую долго и щасливо.
Задача у неё по проще. Она выковыривает из списков рассылки адреса, и писает в базульку с ключевым полем mail. А находит она их так: берёт открывающийся тег, проверяет есть ли за ним собака, находит закрывающийся тег - и вырезает текст от позиции откр. тега до закр-ся. Не находит собаку раньше закр.тега - начинает снова этот цикл со след.откр.тега.