利用VB提取HTML檔案中的EMAIL地址

來源:互聯網
上載者:User
  電子郵件(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地址。

相關文章

Alibaba Cloud 10 Year Anniversary

With You, We are Shaping a Digital World, 2009-2019

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。