利用VB提取HTML文件中的EMAIL地址
| 電子郵件(EMAIL)是INTERNET上應(yīng)用最廣泛的一種服務(wù)之一。我們每天都在使用電子郵件，有時為了宣傳我們的產(chǎn)品、網(wǎng)站等，更是離不開電子郵件，這就需要收集很多的EMAIL地址。下面我們將向大家介紹用VB自編一個EMAIL地址提取器，用來提取保存在我們硬盤中的HTML文件中所包含的EMAIL地址。 |
| 一 設(shè)計界面 |
| 進入VB，選擇“標準EXE”新建一工程，選擇“工程”菜單下的“引用”，選中Microsoft scripting Runtime”，然后再選擇“工程”菜單中的“部件”，在彈出的對話框中選擇“Microsoft common dialog control 6.0”，在工具箱中加入通用對話框控件。接下來在默認窗體FORM1上添加三個標簽控件，一個文本框控件text1，一個列表框控件LIST1，并命名為lstemail，三個命令command1~command3,其Caption屬性分別設(shè)置為“提取”、“整理”、“保存”，設(shè)置完成的界面如下圖所示： |
| ?? |
| 二 輸入源程序 |
| 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) <> "http://") 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?G查找該文件夾的所有文件 |
| For Each f In fd.Files |
| If UCase(f.Name) Like UCase(FileName) Then |
| Label2 = f.Path |
| StripEmail (f.Path) |
| lblEmail = "已查找到的地址數(shù)為: " & lstEmail.ListCount |
| End If |
| DoEvents |
| Next |
| ' Part II?G循環(huán)查找所有子文件夾 |
| For Each sfd In fd.SubFolders |
| FindFile sfd, FileName ' 循環(huán)查找 |
| Next |
| End Sub |
| ?? |
| Private Sub Command2_Click() |
| '去掉重復(fù)的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() |
| '設(shè)置文件名 |
| 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中文企業(yè)版中運行通過。以上程序稍加修改即可實現(xiàn)提取其他類型文件中的EMAIL地址。 |
鄭重聲明：本文版權(quán)歸原作者所有，轉(zhuǎn)載文章僅為傳播更多信息之目的，如作者信息標記有誤，請第一時間聯(lián)系我們修改或刪除，多謝。
新聞熱點
疑難解答
