'搜集的 email 地址的保存位置

strFile = "d:\email.txt"

srtUrl = "http://bbs.aaa.com"

iStart = 1 '用户ID最小值

iEnd = 1000 '用户ID最大值

For i=iStart to iEnd
 
 
 strUrl1 = strUrl & "/dispuser.asp?id=" & cstr(i)

 strRet = OpenUrl(strurl1)
 
 strRet = getMid(strRet,"mailto:",">") '这个地方可能需要灵活做一些改变

 If i mod 100=0 then
 call WriteToFile(strFile,strA)
 strA = ""
 else
 if strRet<>"" then strA = strA & strRet & vbCrLf
 end if
 
 Wscript.Echo i & vbTab & strRet

Next

Sub WriteToFile(strFile,str)
 Dim fso, f
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set f = fso.OpenTextFile(strfile, 8, True)
 f.Write str
 set f= nothing
 set fso=nothing
End Sub

Function bytes2BSTR(vIn)
 Dim i
 strReturn = ""
 For i = 1 To LenB(vIn)
 ThisCharCode = AscB(MidB(vIn,i,1))
 If ThisCharCode < &H80 Then
 strReturn = strReturn & Chr(ThisCharCode)
 Else
 NextCharCode = AscB(MidB(vIn,i+1,1))
 strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
 i = i + 1
 End If
 Next
 bytes2BSTR = strReturn
End Function

Function OpenUrl(strUrl)
 
 on Error Resume Next

 Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
 xmlhttp.open "GET",(strUrl ),false
 xmlhttp.send
 OpenUrl=bytes2BSTR(xmlhttp.ResponseBody)
 
 Set xmlhttp = Nothing
End Function

Function getMid(str, str1, str2)
 Dim i
 Dim j
 str11 = ""
 i = InStr(str, str1)
 If i > 0 Then
 j = InStr(i, str, str2)
 If j > 0 Then
 str11 = Mid(str, i + Len(str1), j - i - Len(str1))
 End If
 End If
 getMid = str11
End Function