利用VB提取HTML文件中的EMAIL地址

利用VB提取HTML文件中的EMAIL地址

    电子邮件(EMAIL)是INTERNET上应用最广泛的一种服务之一。我们每天都在使用电子邮件，有时为了宣传我们的产品、网站等，更是离不开电子邮件，这就需要收集很多的EMAIL地址。下面我们将向大家介绍用VB自编一个EMAIL地址提取器，用来提取保存在我们硬盘中的HTML文件中所包含的EMAIL地址。

一 设计界面

    进入VB，选择“标准EXE”新建一工程，选择“工程”菜单下的“引用”，选中Microsoft scripting Runtime”，然后再选择“工程”菜单中的“部件”，在弹出的对话框中选择“Microsoft common dialog control 6.0”，在工具箱中加入通用对话框控件。接下来在默认窗体FORM1上添加三个标签控件，一个文本框控件text1，一个列表框控件LIST1，并命名为lstemail，三个命令command1~command3,其Caption属性分别设置为“提取”、“整理”、“保存”，设置完成的界面如下图所示：



二 输入源程序

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)

'查找EMAIL标志

If tmpEmail2 = "mailto:" Then

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

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 Folder

Set fd = fs.GetFolder(Text1)

Command1.Enabled = False

Screen.MousePointer = vbHourglass

FindFile fd, "*.htm" 'Text1.Text

Command1.Enabled = True

Screen.MousePointer = vbDefault

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地址

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 & "个地址"

End Sub

'保存

Private Sub Command3_Click()

'设置文件名

Dim strname As String

commondialog1.Filter = "文本文件(*.txt)|*.txt"

commondialog1.ShowSave

If commondialog1.FileName <> "" Then

strname = commondialog1.FileName

Else

strname = App.Path & "\emailaddress.txt"

End If

'保存文件

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

End Sub

本程序在WINDOWS ME、VB6.0中文企业版中运行通过。以上程序稍加修改即可实现提取其他类型文件中的EMAIL地址。