| 广告招租，e-mail:yesize@hotmail.com
|
|
广告招租，e-mail:yesize@hotmail.com
电子邮件(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地址。
版权说明：作品来源于网上，版权归作者所有，如果无意中侵犯了您的版权，请来信告知，本站将在3个工作日内删除。yesize@hotmail.com |
|
 热门小游戏分类 |
|
|
|
加入最爱
