最新研究结果……
Function GetEmail(ByVal TemTxt As String)
Dim Pointer As Long
Dim TopIndex As Long, DownIndex As Long
PoinTer = InStr(1, tmpTxt, "@")
If PoinTer = 0 Then Exit Sub
Do While PoinTer <> 0
    TopIndex = PoinTer
    DownIndex = PoinTer
    For i = PoinTer To 1 Step -1
        AscCode = Asc(Mid(tmpTxt, i, 1))
        If AscCode = 46 Or (AscCode >= 48 And AscCode <= 57) Or (AscCode >= 64 And AscCode <= 90) Or AscCode = 95 Or (AscCode >= 97 And AscCode <= 122) Then
        '
        Else
            TopIndex = i + 1
            Exit For
        End If
        DoEvents
    Next i
    If i <= 0 Then MsgBox "程序错误，结束提取过程", vbExclamation, "警告": Exit Sub
    For i = PoinTer To Len(tmpTxt)
        AscCode = Asc(Mid(tmpTxt, i, 1))
        If AscCode = 46 Or (AscCode >= 48 And AscCode <= 57) Or (AscCode >= 64 And AscCode <= 90) Or AscCode = 95 Or (AscCode >= 97 And AscCode <= 122) Then
        Else
            DownIndex = i - 1
            Exit For
        End If
        DoEvents
    Next i
    If i >= Len(tmpTxt) Then MsgBox "发生未知错误或到文档尾未发现E-mail信息", vbExclamation, "警告": Exit Sub
    GetEmail=GetEmail & Mid(tmpTxt, TopIndex, DownIndex - TopIndex + 1) & vbCrlf
    PoinTer = InStr(DownIndex, tmpTxt, "@")
    DoEvents
Loop
End Function

经检测，这个函数可以将TmpTxt传入的文本中的email准确的提取出来。目前没有进行代码优化，属于初始版本，欢迎大家学习优化！