Después de estudiar durante dos días, creé el siguiente código y lo compartí con cada colega. El rastreo de datos no es correcto.
Establecer r = server.createObject (microsoft.xmlhttp)
R.open get, url, falso,
R.SetRequestHeader Referer, URL
R.send
str1 = B2S (R. -ResponseBody)
str1 = reemplazar (str1 ,,,)
establecer reg = nuevo regexp
reg.multiline = verdadero
Reg.Global = True
reg.ignorecase = True
str_top = <font color =#fb5e3c>
str_bottom = </font>
reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Establecer coincidencias = reg.execute (STR1)
str1 =
Para cada partido1 en partidos
Str1 = Match1.value
Próximo
Establecer coincidencias = nada
Establecer reg = nada
str1 = reemplazar (reemplazar (str1, str_top,), str_bottom,)
conn.execute (actualizar webtable set pr = '& str1 &' donde id = & id)
final
Sub Error (STR) Seleccione Caso STR
Caso 1
Response.write <br> & nbsp; & nbsp; El motor de búsqueda está vacío, por favor contacte <a href = mailto: [email protected]> [email protected] </a>
Caso 2
Response.write <br> & nbsp; & nbsp; el nombre del sitio está vacío, por favor contacte <a href = mailto: [email protected]> [email protected] </a>
Caso 3
Response.write <br> & nbsp; & nbsp; El motor de búsqueda que ingresó no es compatible con este programa, comuníquese con <a href = mailto: [email protected]> [email protected] </a> </body> <</body <</body < /html>
Caso 4
Response.write <br> & nbsp; & nbsp; error desconocido: los datos no se pueden rastrear, por favor <font color = blue> <a href = javaScript: ubicación.reload ();> actualizar </a> </font> intente nuevamente < /Body> </ html>
final seleccionar
respuesta.
End Subsub Google (Strurl, ID, All) url = http: //www.google.cn/search? Complete = 1 & hl = zh-cn & q = sitio%3a & strurl && meta =
str = gethttppage (url)
Si str = entonces
conn.execute (actualizar webStable set Google = '0' donde id = e id)
demás
establecer reg = nuevo regexp
reg.multiline = verdadero
reg.global = falso
reg.ignorecase = True
str_top = <td align = ahora nowrap> <font size = -1>
str_bottom = </font> </td> </tr> </table>
reg.pattern = & str_top & ((.)*) & str_bottom &
Establecer coincidencias = reg.execute (STR)
Para cada partido1 en partidos
Str = Match1.value
Próximo
Establecer coincidencias = nada
Si Instr (str, <html>) = 1 entonces
str2 = 0
demás
str = split (str, </b>)
str1 = str (3)
str2 = split (str1, <b>) (1)
final si
Si str2 = o len (str2)> 200 entonces
conn.execute (actualizar webStable set Google = '0' donde id = e id)
demás
conn.execute (actualizar webStable set Google = '& str2 &' Where id = & id)
final si
final si
Final de subsub baidu (str, id, all) 'llamar print_do (baidu) si all = n entonces entonces
url = http: //www.baidu.com/s? wd = sitio%3a & str && cl = 3
demás
strext = split (str ,.)
url = http: //www.baidu.com/s? wd = & strext (0) && cl = 3
final si
'Response.write (<br> URL de Baidu: & URL) si ISOBJInstalled (asphttp.conn) = true entonces
str = getAsphttppage (URL)
demás
str = gethttppage (url)
Final si
Si str = entonces
Error de llamada (4)
demás
establecer reg = nuevo regexp
reg.multiline = verdadero
reg.global = falso
reg.ignorecase = True
str_top = <td align = ahora nowrap>
str_bottom = </td>
reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Establecer coincidencias = reg.execute (STR)
Para cada partido1 en partidos
Str = Match1.value
Próximo
Establecer coincidencias = nada
Establecer reg = NothingResponse.write <br>
'Response.write & nbsp; & nbsp;
Si str = o len (str)> 200 entonces
conn.execute (actualizar webtable set baidu = '0' donde id = & id)
demás
Si Instr (str, aproximadamente) = 0 entonces
keyw = página
demás
keyw = aproximado
final si
str = mid (str, (instr (str, keyw) +1), (instr (str, artículo) -Instr (str, keyw) -1)))
Respuesta.WRITE STR
conn.execute (actualizar webStable set baidu = '& reemplazar (reemplazar (str ,,,) ,,) y' donde id = & id)
final si
final si
Subsuberante Alexa (Strurl, ID)
url = http: //www.alexa.com/data/details/traftic_details? Q = & url = & strurl
Establecer r = server.createObject (microsoft.xmlhttp)
R.open get, url, falso,
R.SetRequestHeader Referer, URL
R.send
str1 = bytes2bstr (R.ResponseBody)
str1 = reemplazar (str1 ,,,)
establecer reg = nuevo regexp
reg.multiline = verdadero
Reg.Global = True
reg.ignorecase = True
str_top = <!-¿Sabías
str_bottom = </span> <br>
reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
Establecer coincidencias = reg.execute (STR1)
str1 =
Para cada partido1 en partidos
str1 = str1 y match1.value
Próximo
Establecer coincidencias = nada
Establecer reg = nada
str1 = reemplazar (str1, <!-¿Sabía? Alexa ofrece estos datos programáticamente. Visite http://aws.amazon.com/awis para obtener más información sobre el servicio de información web de Alexa .-->,))
Si str1 <> entonces
str1 = reemplazar (str1, <clase span,)
str1 = reemplazar (str1, </span> </span>,)
str1 = reemplazar (str1 ,,)
str1 = reemplazar (str1 ,,)
str1 = split (str1, <br>) (0)
Si cstr (derecha (str1,7)) = </span> entonces entonces
str1 = izquierda (TRIM (STR1), LEN (STR1) -7)
final si
if isnumérico (str1) entonces
num = str1
demás
csstxt = getAlexacss ()
num =
str1 = Split (str1, </span>)
para i = 0 a Ubund (str1)
str2 = str1 (i)
Si se deja (str2, instr (str2, =)) <> entonces
num = num & izquierda (str2, instr (str2, =)-1)
str2 = right (str2, len (str2) -instr (str2, =))
final si
str3 = split (str2,>)
para j = 0 a Ubund (str3)
próximo
Si str3 (0) <> entonces
Si no es isnumérico (str3 (0)) entonces
if instrer (csstxt, str3 (0)) = 0 entonces
num = num & str3 (1)
final si
final si
final si
próximo
final si
demás
num = 0
final si
sql = update webtable set alexa = '& num &' where id = & id
Response.Write (<Script> Alert ('& Sql &') </script>))
Conn.execute (SQL)
Subfunción final B2S (STR)
Atenuado
Establecer O = Server.CreateObject (ADODB.Stream)
O.Type = 1
O.Mode = 3
O.Apen
O.WRITE STR
O.Position = 0
O.Type = 2
O.Charset = GB2312
B2s = O.ReadText
O.Cerrar
Establecer O = nada
Función final 'Obtener la hoja de estilo de Alexa
Función getAlexacss ()
url = http: //client.alexa.com/common/css/scramble.css
If isobjinstalled (asphttp.conn) = true entonces
str = getAsphttppage (URL)
demás
str = gethttppage (url)
Final si
GetAlexacss = str
Funcions FunctionsUn PRIT_DO (STR)
Response.Write <Script>
Response.Write Función HiddenLoad ()
Respuesta.Write {
Response.Write Parent.do & str & .style.display = 'Ninguno';
Response.Write}
Response.Write </script>
Respuesta.Write <Body LeftMargin = 0 topMargin = 0 marginwidth = 0 marginheight = 0 bgcolor =#f2f2f2 onload = Hiddenload ()>
Subfunción final gethttppage (URL)
En el currículum de error siguiente
Dim http
Establecer http = server.CreateObject (Microsoft.xmlhttp)
Http.open get, url, falso
Http.send ()
Si http.readyState <> 4 entonces entonces
función de salida
final si
gethttppage = bytes2bstr (http.ResponseBody)
Establecer http = nada
Si err.number <> 0 entonces Err.Clear
FINTO FINFUNTIVE BYTES2BSTR (VIN)
Dim BytesStream, Stringreturn
Establecer byteStream = server.CreateObject (ADODB.Stream)
Bytesstream.type = 2
Bytesstream.apor
Bytesstream.writeText vin
ByteStream.position = 0
ByteStream.charset = GB2312
ByteStream.position = 2
StringReturn = bytesTream.readText
Bytesstream.clare
Establecer bytesstream = nada
Bytes2bstr = stringreturn
Funcionfunction final getAsphttppage (URL)
Si url = entonces
función de salida
final si
Establecer httpobj = server.createObject (asphttp.conn)
'Configure un servidor proxy, usuarios que usan el proxy para acceder a Internet deben establecer esta opción
Si proxyip = 1 entonces
Httpobj.proxy = 192.168.5.254: 808
final si
Httpobj.timeout = 45
Httpobj.url = url
Httpobj.requestmethod = get
getAphttppage = httpobj.geturl
establecer httpobj = nada
Funcionfunction final isObjinstalled (strclassstring)
En el currículum de error siguiente
Isobjinstalled = falso
Err = 0
Dim xtestobj
Establecer xtestobj = server.createObject (strclassString) si 0 = err entonces
Si asphttpopen = 1 entonces
Isobjinstalled = verdadero
'Respuesta. Escribe el componente actual ASPHTTP
Demás
Isobjinstalled = falso
'Respuesta. Escribe el componente actual XMLHTTP
Final si
Demás
Isobjinstalled = falso
'Respuesta. Escribe el componente actual XMLHTTP
Fin si se establece xtestobj = nada
Err = 0
Función final