利用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地址。 

原文轉自：http://www.anti-gravitydesign.com