После учебы в течение двух дней я создал следующий код и поделился им с каждым коллегой. Поседание данных не верно.
Установить r = server.createObject (microsoft.xmlhttp)
R.Open Get, url, false,
R.SetRequestheader Рефера, URL
R.Send
str1 = b2s (r.responsebody)
str1 = заменить (str1 ,,,)
Установить reg = new Regexp
reg.multiline = true
reg.global = true
reg.ignorecase = true
str_top = <font color =#fb5e3c>
str_bottom = </font>
reg.pattern = & str_top & ((. | n)*?) & str_bottom &
SET MATCHES = Reg.Execute (str1)
str1 =
Для каждого матча в матчах
str1 = match1.value
Следующий
Установить совпадения = ничего
Установить reg = ничего
str1 = заменить (заменить (str1, str_top,), str_bottom,)
conn.execute (обновление webtable set pr = '& str1 &' где id = & id)
Конец суб
Sub Error (Str) выберите Case Str
Случай 1
response.write <br> & nbsp; & nbsp; поисковая система пуста, пожалуйста, свяжитесь с <a href = mailto: [email protected]> [email protected] </a>
Случай 2
response.write <br> & nbsp; & nbsp; имя сайта пусто, пожалуйста, свяжитесь с <a href = mailto: [email protected]> [email protected] </a>
Случай 3
response.write <br> & nbsp; & nbsp; Поисковая система, которую вы введены /html>
Случай 4
response.write <br> & nbsp; & nbsp; неизвестная ошибка - данные не могут быть заполнены, пожалуйста <font color = blue> <a href = javascript: location.reload ();> Обновить </a> </font> Попробуйте еще раз < /body> </html>
конец выбора
response.end
End Subsub Google (Strurl, Id, All) url = http: //www.google.cn/search?
str = gethttppage (url)
Если str = then
conn.execute (обновление webtable set Google = '0' где id = & id)
еще
Установить reg = new Regexp
reg.multiline = true
reg.global = false
reg.ignorecase = true
str_top = <td align = nowrap> <font size = -1>
str_bottom = </font> </td> </tr> </table>
reg.pattern = & str_top & ((.)*) & str_bottom &
Установить совпадения = reg.execute (str)
Для каждого матча в матчах
str = match1.value
Следующий
Установить совпадения = ничего
Если instr (str, <html>) = 1 тогда
str2 = 0
еще
str = split (str, </b>)
str1 = str (3)
str2 = split (str1, <b>) (1)
конец, если
Если str2 = или len (str2)> 200, тогда
conn.execute (обновление webtable set Google = '0' где id = & id)
еще
conn.execute (обновление webtable set google = '& str2 &' где id = & id)
конец, если
конец, если
End subsub baidu (str, id, all) 'call print_do (baidu), если все = n тогда
url = http: //www.baidu.com/s? wd = site%3a & str && cl = 3
еще
strext = split (str ,.)
url = http: //www.baidu.com/s? wd = & strext (0) && cl = 3
конец, если
'response.write (<br> url baidu's url: & url) if isobjinstalled (asphttp.conn) = true then
str = getAsphttppage (url)
еще
str = gethttppage (url)
Конец, если
Если str = then
Ошибка вызова (4)
еще
Установить reg = new Regexp
reg.multiline = true
reg.global = false
reg.ignorecase = true
str_top = <td align = прямо nowrap>
str_bottom = </td>
reg.pattern = & str_top & ((. | n)*?) & str_bottom &
Установить совпадения = reg.execute (str)
Для каждого матча в матчах
str = match1.value
Следующий
Установить совпадения = ничего
Установить reg = nothoutResponse.write <br>
'response.write & nbsp; & nbsp;
Если str = или len (str)> 200, тогда
conn.execute (обновление webtable set baidu = '0', где id = & id)
еще
Если instr (str, приблизительно) = 0 тогда
KeyW = Page
еще
keyw = приблизительный
конец, если
str = mid (str, (instr (str, keyw) +1), (instr (str, artice) -instr (str, keyw) -1)))
response.write str
conn.execute (обновление WebTable set baidu = '& reply (reply (str ,,,) ,,) и' где id = & id)
конец, если
конец, если
End Subbub Alexa (Strurl, Id)
url = http: //www.alexa.com/data/details/traffic_details? q = & url = & strurl
Установить r = server.createObject (microsoft.xmlhttp)
R.Open Get, url, false,
R.SetRequestheader Рефера, URL
R.Send
str1 = bytes2bstr (r.responsebody)
str1 = заменить (str1 ,,,)
Установить reg = new Regexp
reg.multiline = true
reg.global = true
reg.ignorecase = true
str_top = <!-Вы знаете
str_bottom = </span> <br>
reg.pattern = & str_top & ((. | n)*?) & str_bottom &
SET MATCHES = Reg.Execute (str1)
str1 =
Для каждого матча в матчах
str1 = str1 & match1.value
Следующий
Установить совпадения = ничего
Установить reg = ничего
str1 = Заменить (str1, <!-Вы знаете? Alexa предлагает эти данные программно. Посетите http://aws.amazon.com/awis для получения дополнительной информации о службе веб-информации Alexa .-->,)
Если str1 <> then
str1 = заменить (str1, <span class,)
str1 = reply (str1, </span> </span>,)
str1 = заменить (str1 ,,)
str1 = заменить (str1 ,,)
str1 = split (str1, <br>) (0)
Если cstr (right (str1,7)) = </span> then
str1 = слева (Trim (str1), len (str1) -7)
конец, если
Если isnumeric (str1), то
num = str1
еще
csstxt = getalexacss ()
num =
str1 = split (str1, </span>)
для i = 0 до ubund (str1)
str2 = str1 (i)
Если осталось (str2, instr (str2, =)) <> then
num = num & left (str2, instr (str2, =)-1)
str2 = справа (str2, len (str2) -instr (str2, =))
конец, если
str3 = split (str2,>)
для j = 0 до ubund (str3)
следующий
Если str3 (0) <> then
Если нет, не является is -inumeric (str3 (0)), то тогда
Если instr (csstxt, str3 (0)) = 0 then
num = num & str3 (1)
конец, если
конец, если
конец, если
следующий
конец, если
еще
num = 0
конец, если
SQL = Обновление WebTable Установите Alexa = '& num &', где id = & id
response.write (<script> alert ('& sql &') </script>)
conn.execute (sql)
Конечная подфункция B2S (STR)
DIM O.
Установите o = server.createObject (adodb.stream)
O.Type = 1
O.Mode = 3
О.О.
O.Write Str
O.Position = 0
O.Type = 2
O.CHARSET = GB2312
B2S = O.ReadText
O.Close
Установить O = ничего
Конечная функция 'Получить таблицу стилей Alexa
Function getalexacs ()
url = http: //client.alexa.com/common/css/scramble.css
Если isobjinstalled (asphttp.conn) = true then
str = getAsphttppage (url)
еще
str = gethttppage (url)
Конец, если
Getalexacs = str
end functionsub print_do (str)
response.write <Script>
response.write function hiddenload ()
response.write {
response.write parent.do & str & .style.display = 'none';
response.write}
response.write </script>
response.Write <Body Leatsmargin = 0 topmargin = 0 marginwidth = 0 marginheight = 0 bgcolor =#f2f2f2 onload = hiddenload ()>
конечная подфункция gethttppage (url)
при ошибке резюме следующим
Dim http
Установить http = server.createObject (microsoft.xmlhttp)
Http.open get, url, false
Http.send ()
Если http.readystate <> 4 то
Выходная функция
конец, если
gethttppage = bytes2bstr (http.responsebody)
Установить http = ничего
Если err.number <> 0, то err.clear
Конечная функция функции Bytes2BSTR (VIN)
DIM 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 = ничего
Bytes2bstr = stringterurn
Конечная функция функции getAsphttppage (url)
Если url = then
Выходная функция
конец, если
Установить httpobj = server.createObject (asphttp.conn)
'Установите прокси -сервер, пользователи, которые используют прокси для доступа к Интернету, должны установить эту опцию
Если Proxyip = 1 тогда
Httpobj.proxy = 192.168.5.254: 808
конец, если
Httpobj.timeout = 45
Httpobj.url = url
Httpobj.requestmethod = get
getaphttppage = httpobj.geturl
Установите httpobj = ничего
Конечная функция функции isobjinstalled (strclassstring)
При ошибке резюме следующим
Isobjinstalled = false
Err = 0
Dim Xtestobj
Установить xtestobj = server.createObject (strClassString), если 0 = err Then
Если asphttpopen = 1 тогда
Isobjinstalled = true
'Response.prite ток компонент asphttp
Еще
Isobjinstalled = false
'Response.write ток компонент xmlhttp
Конец, если
Еще
Isobjinstalled = false
'Response.write ток компонент xmlhttp
Конец, если установлен xtestobj = ничего
Err = 0
Конечная функция