利用VB提取HTML文件中的EMAIL地址
2008-04-09 04:41:46来源：互联网 阅读 ()
电子邮件(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地址。
标签：
版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有
上一篇：VB.NET多线程应用
下一篇：vb设计数据库电子邮件程序
IDC资讯： 主机资讯 注册资讯 托管资讯 vps资讯 网站建设
网站运营： 建站经验 策划盈利 搜索优化 网站推广 免费资源
网络编程： Asp.Net编程 Asp编程 Php编程 Xml编程 Access Mssql Mysql 其它
服务器技术： Web服务器 Ftp服务器 Mail服务器 Dns服务器 安全防护
软件技巧： 其它软件 Word Excel Powerpoint Ghost Vista QQ空间 QQ FlashGet 迅雷
网页制作： FrontPages Dreamweaver Javascript css photoshop fireworks Flash
