从网页里查找Email地址

Question

有这样一种程序，能够查找网上某网页及其链接的网页上的Email地址，可以无穷的查找下去，小弟想做一个类似的程序，但没有想到一个快速有效的算法，不知哪有这方面的源程序可以参考，大侠赐教！！

Answer 1

用WebBrowser吧，找到href="mailto纪录，然后按找到的URL进行挖掘，知道没有URL为止。
:~~D 够累~~~~

Answer 2

我就知道有个可以在自己硬盘上一直找html 然后extract emails..不知道你能不能改成其他的！这样要不弄个list1box 专门来放url.
url 的抓取用些spider 可以做的来. htmldocument.links.length-1 来取得linkslist.additem然后再找email 不过我看advance email extractor 是用winsock 实现的，还是先抓文本，然后找@两面的东西。addlist 然后再删除重复的

Answer 3

主要是想找一个，高速，有效的算法，我看advance email extractor好像默认只能查25000个网页，要是多了怎么办，国内的有些类似软件差得更少，我想这种程序不光可以搜email，还能找其他别的东西

Answer 4

无穷的话-还是靠机器的性能我买了aee pro 运行一段时间机器就慢的不行了！占用资源太大！web data explorer 可以查email tel faxe title 等等 实际上都一样！你说的算法是什么概念！递归算不算算法？？我是面人，别见笑！就会买，不会编:-))

Answer 5

我看了aee。估计是c++ 语言写的吧！能不能看出是什么写的！那50个线程够快的-估计vb 不会实现的？？

Answer 6

加一个webbrowser,listbox,commandbutton: 
如当前登录的页面是sina的首页
sub command1_click()
for i=0 to webbrowser1.document.links.length
    if instr(webbrowser1.document.links(i).href,"mail to")<>0 then
        list1.additem webbrowser1.document.links(i).href
    end if
next
end sub
自己测试一下, 我没有试过, 但基本思路是这样

Answer 7

to:hengxing54对象变量或with 快变量未设置

Answer 8

http://expert.csdn.net/Expert/topic/1555/1555186.xml?temp=.2153894看看这个里面的代码

Answer 9

 Sub RecurseFr(HTMLDoc As HTMLDocument)  If HTMLDoc Is Nothing Then
  ' Not an HTLM document
       Exit Sub
    End If
   Dim BODYElement As IHTMLElement
  Set BODYElement = HTMLDoc.body
  If BODYElement.tagName = "BODY" Then
  Dim ELEMENTCo As IHTMLElementCollection
  Set ELEMENTCo = HTMLDoc.links
  Dim Element As HTMLAnchorElement
  For Each Element In ELEMENTCo
  listlinks.AddItem (Element.href)
  Next
  End If
  Dim HTMLFrames As IHTMLFramesCollection2
  Set HTMLFrames = HTMLDoc.frames
  Dim HTMLWnd As HTMLWindow2
  For countFrames = 0 To HTMLFrames.length - 1
  Set HTMLWnd = HTMLFrames(countFrames)
  Call RecurseFr(HTMLWnd.Document)
  Next
  Exit Sub
  MsgBox (Err.Description)
 End Sub
Private Sub btnGetLinks_Click()
 On Error Resume Next
 Dim theControl As WebBrowser
 Set theControl = WebBrowser1
 Dim HTMLDoc As HTMLDocument
 Set HTMLDoc = WebBrowser1.Document
 listlinks.Clear
 Call RecurseFr(HTMLDoc)
End SubPrivate Sub btngoback_Click()
WebBrowser1.GoBack
End SubPrivate Sub btngofoward_Click()
 WebBrowser1.GoForward
End SubPrivate Sub btnNavigate_Click()
WebBrowser1.navigate (editNavURL)
End SubPrivate Sub Form_Load()
Dim DocEvents As HTMLDocument
WebBrowser1.Navigate2 ("http://www.baidu.com")
End Sub
Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
Set DocEvents = Nothing
listlinks.Clear
editElement = ""
editID = ""
End SubPrivate Sub WebBrowser1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
Select Case Command
Case CSC_NAVIGATEBACK
btngoback.Enabled = Enable
Case CSC_NAVIGATEFORWARD
btngoforward.Enabled = Enable
End Select
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
If pDisp Is WebBrowser1.Object Then
Set DocEvents = WebBrowser1.Document
End If
End Sub这是个getlinks 的例子, 你把element 改成'mailto:"就可以了！

Answer 10

不行的！我错了！ 应该加个判断 element 里面有mailto: @ 的list additem

Answer 11

能把源代码发一份给我吗 谢了
[email protected]