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