如何提出文本文件中的email地址，会这个算法的请与我联系。

Question

给高手。

Answer 1

'提取网页文件中的 Email 地址
Dim X, Y, St1, St2, tmpY As Integer
'提取 EMAIL 地址子程序
Private Sub StripEmail(FilePath As String)
        Dim tmpEmail1, tmpEmail2 As String
    Open FilePath For Input As #1
    Do Until EOF(1)
       On Error Resume Next
       Input #1, tmpEmail1
        For X = 1 To Len(tmpEmail1)
            tmpEmail2 = Mid(tmpEmail1, X, 7)
                If LCase$(tmpEmail2) = "mailto:" Then     '查找EMAIL标志
                   St1 = X
                  tmpY = X + 1
                       For Y = 1 To Len(tmpEmail1)
                           tmpEmail2 = Mid(tmpEmail1, tmpY, 1)
                        If tmpEmail2 = Chr(34) Or tmpEmail2 = "?" Then
                           St2 = tmpY
                           tmpEmail2 = Mid(tmpEmail1, St1 + 7, ((St2 - St1) - 7))
                           If (Left(tmpEmail2, 2) <> "//") And (Left(tmpEmail2, 1) <> " ") Then
                              For j = 1 To Len(tmpEmail2)
                                 If Mid(tmpEmail2, j, 1) = "@" Then GoTo ADD
                              Next j
                       Exit For
ADD:                             tmpEmail2 = Left$(tmpEmail2, (InStr(1, tmpEmail2, " ", vbTextCompare)) - 1)  '滤除特殊字符
                                 tmpEmail2 = Left$(tmpEmail2, (InStr(1, tmpEmail2, ">", vbTextCompare)) - 1)  '滤除特殊字符
                                 tmpEmail2 = Left$(tmpEmail2, (InStr(1, tmpEmail2, "'", vbTextCompare)) - 1)  '滤除特殊字符
                                 lstEmail.AddItem tmpEmail2
        Exit For
                           End If
                        End If
                           tmpY = tmpY + 1
                       Next Y
                End If
        Next X
    Loop
    Close #1
End Sub
Private Sub Command1_Click()
Dim fs As New FileSystemObject        ' 建立 FileSystemObject
Dim fd As Folder                      ' 定义 Folder 对象
Dim sfd As FolderSet fd = fs.GetFolder(Text1)
Command1.Enabled = False
Screen.MousePointer = vbHourglass     '置鼠标为忙状态FindFile fd, "*.htm"                  '在指定的目录中及其子目录中查找文件(子程序)
FindFile fd, "*.html"                 '在所有的网页文件中查找Screen.MousePointer = vbDefault       '恢复鼠标状态
Command2.Enabled = True
Command3.Enabled = True
End Sub
Sub FindFile(fd As Folder, FileName As String)Dim sfd As Folder, f As File
' Part I查找该文件夹的所有文件
For Each f In fd.Files
    If UCase(f.Name) Like UCase(FileName) Then
       Label2 = f.Path
       StripEmail (f.Path)           '查找电子邮件子程序
       lblEmail = "已查找到的有效地址个数为: " & lstEmail.ListCount
    End If
  DoEvents
Next
' Part II循环查找所有子文件夹
For Each sfd In fd.SubFolders
    FindFile sfd, FileName           ' 循环查找
Next
End Sub
Private Sub Command2_Click()
'去掉重复的 Email 地址
Screen.MousePointer = vbHourglass    '置鼠标为忙状态
For i = 0 To lstEmail.ListCount - 1
    For X = 0 To lstEmail.ListCount - 1
        If i = X Then GoTo Nextx
           If LCase(lstEmail.List(X)) = LCase(lstEmail.List(i)) Then
              On Error Resume Next
              lstEmail.RemoveItem X  '移除重复的地址
           End If
Nextx:
    Next X
Next i
lblEmail = "共有" & lstEmail.ListCount & "个有效地址"
Screen.MousePointer = vbDefault      '恢复鼠标状态
End Sub
Private Sub Command3_Click()
'保存到文件 设置文件名
Dim strname As String
    strname = App.Path & "\Email.TXT"
Open strname For Output As #1
On Error Resume Next
For i = 0 To lstEmail.ListCount - 1
    Print #1, lstEmail.List(i)
Next
Close #1
MsgBox "邮件地址已保存到  " & strname & " 文件中", vbOKOnly, "提取网页文件中的 Email 地址"
End Sub
Private Sub Form_Load()
        Command2.Enabled = False
        Command3.Enabled = False
End Sub

Answer 2

以上程序需要3个Command、1个TextBox、1个Label、1个ListBox

Answer 3

这个是给网页中有链接的（mailto字符）的算法。
如果他没有mailto字符呢，
目的就达不到了。