Setelah belajar selama dua hari, saya membuat kode berikut dan membagikannya dengan masing -masing kolega. Data merayap tidak benar.
Set R = Server.CreateObject (microsoft.xmlhttp)
R.open get, url, false,
Referensi R.SetRequestheader, URL
R.send
STR1 = B2S (R.ResponseBody)
str1 = ganti (str1 ,,,)
Setel reg = regexp baru
Reg.Multiline = Benar
Reg.Global = Benar
Reg.ignorecase = true
str_top = <font color =#fb5e3c>
str_bottom = </font>
Reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Set kecocokan = reg.execute (str1)
str1 =
Untuk setiap match1 dalam pertandingan
str1 = match1.value
Berikutnya
Setel kecocokan = tidak ada
Setel Reg = Tidak Ada
str1 = ganti (ganti (str1, str_top,), str_bottom,)
Conn.execute (Perbarui Webtable Set Pr = '& Str1 &' Where Id = & Id)
akhir sub
Sub error (str) pilih case str str
Kasus 1
response.write <br> & nbsp; & nbsp; mesin pencari kosong, silakan hubungi <a href = mailto: [email protected]> [email protected] </a>
Kasus 2
response.write <br> & nbsp; & nbsp; Nama situs kosong, silakan hubungi <a href = mailto: [email protected]> [email protected] </a>
Kasus 3
response.write <br> & nbsp; & nbsp; mesin pencari yang Anda masukkan tidak didukung oleh program ini, silakan hubungi <a href = mailto: [email protected]> [email protected] </a> </bodotmail> /html>
Kasus 4
response.write <br> & nbsp; & nbsp; kesalahan yang tidak diketahui - data tidak dapat dirangkak, tolong <font color = blue> <a href = javascript: location.reload ();> refresh </a> </font> coba lagi < /body> </html>
Akhiri Pilih
respons.end
End subsub google (strurl, id, all) url = http: //www.google.cn/search? Lengkap = 1 & hl = zh-cn & q = situs%3a & strurl && meta =
str = getHttppage (url)
Jika str = lalu
Conn.execute (Perbarui Webtable Set Google = '0' Where ID = & ID)
kalau tidak
Setel reg = regexp baru
Reg.Multiline = Benar
Reg.global = false
Reg.ignorecase = true
str_top = <td align = sekarang rap> <font size = -1>
str_bottom = </font> </td> </tr> </able>
Reg.pattern = & str_top & ((.)*) & str_bottom &
Set kecocokan = reg.execute (str)
Untuk setiap match1 dalam pertandingan
str = match1.value
Berikutnya
Setel kecocokan = tidak ada
if instr (str, <html>) = 1 lalu
STR2 = 0
kalau tidak
str = split (str, </b>)
str1 = str (3)
str2 = split (str1, <b>) (1)
akhiri jika
Jika str2 = atau len (str2)> 200 lalu
Conn.execute (Perbarui Webtable Set Google = '0' Where ID = & ID)
kalau tidak
Conn.execute (Perbarui Webtable Set Google = '& str2 &' Where ID = & ID)
akhiri jika
akhiri jika
End subsub baidu (str, id, all) 'call print_do (baidu) jika all = n kemudian
url = http: //www.baidu.com/s? wd = situs%3a & str && cl = 3
kalau tidak
strext = split (str,)
url = http: //www.baidu.com/s? wd = & strext (0) && cl = 3
akhiri jika
'response.write (<br> url baidu: & url) jika isobjinstalled (asphttp.conn) = true kemudian
str = getasphttppage (url)
kalau tidak
str = getHttppage (url)
Akhiri jika
Jika str = lalu
Kesalahan panggilan (4)
kalau tidak
Setel reg = regexp baru
Reg.Multiline = Benar
Reg.global = false
Reg.ignorecase = true
str_top = <td align = sekarang rap>
str_bottom = </td>
Reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Set kecocokan = reg.execute (str)
Untuk setiap match1 dalam pertandingan
str = match1.value
Berikutnya
Setel kecocokan = tidak ada
Setel Reg = NothingResponse.Write <br>
'Response.write & nbsp; & nbsp;
Jika str = atau len (str)> 200 lalu
Conn.execute (Perbarui Webtable Set Baidu = '0' Where Id = & Id)
kalau tidak
if instr (str, kira -kira) = 0 lalu
keyw = halaman
kalau tidak
KEYW = Perkiraan
akhiri jika
str = mid (str, (instr instr (str, ceyw) +1), (instr (str, artikel) -instr (str, keyw) -1)))
Response.write str
conn.execute (perbarui set webtable set baidu = '& ganti (ganti (str ,,,,) ,,) &' di mana id = & id)
akhiri jika
akhiri jika
End Subsub Alexa (Strurl, ID)
url = http: //www.alexa.com/data/details/traffic_details? q = & url = & strurl
Set R = Server.CreateObject (microsoft.xmlhttp)
R.open get, url, false,
Referensi R.SetRequestheader, URL
R.send
str1 = bytes2btr (r.ResponseBody)
str1 = ganti (str1 ,,,)
Setel reg = regexp baru
Reg.Multiline = Benar
Reg.Global = Benar
Reg.ignorecase = true
str_top = <!-Tahukah Anda
str_bottom = </span> <br>
Reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Set kecocokan = reg.execute (str1)
str1 =
Untuk setiap match1 dalam pertandingan
str1 = str1 & match1.value
Berikutnya
Setel kecocokan = tidak ada
Setel Reg = Tidak Ada
str1 = ganti (str1, <!-Tahukah Anda? Alexa menawarkan data ini secara terprogram. Kunjungi http://aws.amazon.com/awis untuk informasi lebih lanjut tentang Layanan Informasi Web Alexa .-->,)
Jika str1 <> lalu
str1 = ganti (str1, <kelas span,)
str1 = ganti (str1, </span> </span>,)
str1 = ganti (str1 ,,)
str1 = ganti (str1 ,,)
str1 = split (str1, <br>) (0)
jika cstr (kanan (str1,7)) = </span> lalu
str1 = kiri (trim (str1), len (str1) -7)
akhiri jika
jika isnumeric (str1) lalu
num = str1
kalau tidak
csstxt = getalexacss ()
num =
str1 = split (str1, </span>)
untuk i = 0 ke ubund (str1)
str2 = str1 (i)
Jika kiri (str2, instr (str2, =)) <> lalu
num = num & left (str2, instr (str2, =)-1)
str2 = kanan (str2, len (str2) -instr (str2, =))
akhiri jika
str3 = split (str2,>)
untuk j = 0 ke ubund (str3)
Berikutnya
Jika str3 (0) <> lalu
jika tidak isnumeric (str3 (0)) lalu
if instr (csstxt, str3 (0)) = 0 lalu
num = num & str3 (1)
akhiri jika
akhiri jika
akhiri jika
Berikutnya
akhiri jika
kalau tidak
num = 0
akhiri jika
SQL = Perbarui Webtable Set Alexa = '& Num &' Where Id = & Id
response.write (<script> alert ('& sql &') </ptript>)
Conn.execute (SQL)
End Subfunction B2S (STR)
Redup o
Set o = server.CreateObject (adodb.stream)
O.Type = 1
O.mode = 3
O.open
O.write str
O.Posisi = 0
O.Type = 2
O.Charset = GB2312
B2s = o.readtext
O.close
Setel o = tidak ada
Fungsi Akhir 'Dapatkan Alexa's Stylesheet
Fungsi getalexacss ()
url = http: //client.alexa.com/common/css/scramble.css
Jika isobjinstalled (asphttp.conn) = true maka
str = getasphttppage (url)
kalau tidak
str = getHttppage (url)
Akhiri jika
Getalexacss = str
END FUNCTIONSUB print_do (str)
Response.write <ript>
response.write function hiddenload ()
response.write {
response.write parent.do & str & .style.display = 'none';
response.write}
response.write </script>
response.write <body leftmargin = 0 topmargin = 0 marginwidth = 0 marginheight = 0 bgcolor =#f2f2f2 onload = hiddenload ()>
end subfungsi getHttppage (URL)
pada kesalahan resume berikutnya
redup http
Setel http = server.CreateObject (microsoft.xmlhttp)
Http.open get, url, false
Http.send ()
Jika http.readystate <> 4 lalu
fungsi keluar
akhiri jika
getHttppage = bytes2btr (http.responseBody)
atur http = tidak ada
Jika err.number <> 0 maka err.clear
End functionFunction bytes2btr (VIN)
Redup bytesstream, stringreturn
Set bytesstream = server.CreateObject (adodb.stream)
Bytesstream.type = 2
Bytesstream.open
Bytesstream.writetext vin
Bytesstream.position = 0
Bytesstream.charset = GB2312
Bytesstream.position = 2
StringReturn = bytesstream.readtext
Bytesstream.close
Set ByTessTream = tidak ada
Bytes2bstr = StringReturn
Fungsi akhir fungsi getasphttppage (url)
Jika url = lalu
fungsi keluar
akhiri jika
Setel httpobj = server.CreateObject (asphttp.conn)
'Siapkan server proxy, pengguna yang menggunakan proxy untuk mengakses internet perlu mengatur opsi ini
Jika proxyip = 1 maka
Httpobj.proxy = 192.168.5.254: 808
akhiri jika
Httpobj.timeout = 45
Httpobj.url = url
Httpobj.requestmethod = get
getaphttppage = httpobj.getUrl
Setel httpobj = tidak ada
Fungsi fungsi akhir isobjinstalled (strclassstring)
Pada kesalahan resume berikutnya
Isobjinstalled = false
Err = 0
Redup xtestobj
Set xtestoBj = server.CreateObject (strclassString) if 0 = err kemudian
Jika asphttpopen = 1 lalu
Isobjinstalled = true
'Response.write Current Component AsphTTP
Kalau tidak
Isobjinstalled = false
'Response.write Current Component xmlhttp
Akhiri jika
Kalau tidak
Isobjinstalled = false
'Response.write Current Component xmlhttp
End jika set xtestoBj = tidak ada
Err = 0
Fungsi akhir