Ein Code zum Erfassen der E-Mail-Adresse des Dongwang-Forums
/**
Autor: Ci Qinqiang
E-Mail: [email protected]
**/
Kürzlich habe ich darüber nachgedacht, wie wir unsere neue Website http://www.up114.com bewerben können.
Suchmaschinenoptimierung ist natürlich die erste Wahl, aber Sie können nicht auf Massenmailing verzichten,
solange Sie das Ziel des Massenmailings auswählen und weniger versenden, sollte es in Ordnung sein, :=—— .
Also habe ich einige Foren zu verwandten Themen gefunden, von denen viele Dongwang-Foren sind. Jetzt muss ich
die E-Mail-Adressen der Forumbenutzer sammeln. Es gibt auch spezielle Tools, die online verkauft werden, aber heute werden wir selbst ein kleines Tool schreiben, das auch funktionieren kann das gleiche Ziel.
Der Code lautet wie folgt. Verwenden Sie Textbearbeitungstools wie Notepad, um ihn als dv.vbs zu speichern.
Bevor Sie ihn verwenden, müssen Sie sich im Forum registrieren und anmelden.
Verwendung: c:cscript dv.vbs ist in Ordnung.
'Der Speicherort der gesammelten E-Mail-Adressen
strFile = "d:email.txt"
srtUrl = " http://bbs.aaa.com "
iStart = 1 'Minimaler Wert der Benutzer-ID
iEnd = 1000 'Maximaler Wert der Benutzer-IDFor
i= iStart bis iEnd
strUrl1 = strUrl & "/dispuser.asp?id=" & cstr(i)
strRet = OpenUrl(strurl1)
strRet = getMid(strRet,"mailto:",">") 'Dieser Ort muss möglicherweise flexibel geändert werden,
wenn ich dann 100=0 modifiziere
Aufruf von WriteToFile(strFile,strA)
strA = ""
anders
wenn strRet<>"" dann strA = strA & strRet & vbCrLf
Ende wenn
Wscript.Echo i & vbTab & strRet
Weiter
Sub WriteToFile(strFile,str)
Dim fso, f
Setze fso = CreateObject("Scripting.FileSystemObject")
Setze f = fso.OpenTextFile(strfile, 8, True)
f.Str. schreiben
setze f= nichts
setze fso=nichts
Sub beenden
Funktion bytes2BSTR(vIn)
Dim ich
strReturn = ""
Für i = 1 Zu LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
Wenn ThisCharCode < &H80 Dann
strReturn = strReturn & Chr(ThisCharCode)
Anders
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
ich = ich + 1
Ende wenn
Nächste
bytes2BSTR = strReturn
Funktion beenden
Funktion OpenUrl(strUrl)
bei Fehler Weiter fortsetzen
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
xmlhttp.open „GET“,(strUrl),false
xmlhttp.send
OpenUrl=bytes2BSTR(xmlhttp.ResponseBody)
Setze xmlhttp = Nothing
Endfunktion
Funktion getMid(str, str1, str2)
Dim ich
J
str11 = ""
i = InStr(str, str1)
Wenn i > 0, dann
j = InStr(i, str, str2)
Wenn j > 0, dann
str11 = Mid(str, i + Len(str1), j - i - Len(str1))
Ende wenn
Ende wenn
getMid = str11
Funktion beenden