Depois de estudar por dois dias, criei o seguinte código e o compartilhei com cada colega. O rastejamento de dados não está correto.
Set r = server.createObject (microsoft.xmlhttp)
R.open get, url, falso,
R.SetRequestHeader Referent, Url
R.Send
STR1 = B2S (R.ResponseBody)
str1 = substituir (str1 ,,,)
SET REG = NOVO 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 MOCHES = REG.EXECUTE (STR1)
str1 =
Para cada correspondência1 em partidas
str1 = match1.value
Próximo
Set Matches = nada
Definir reg = nada
str1 = substituir (substituir (str1, str_top), str_bottom,)
Conn.Execute (Atualizar WebTable Set = '& Str1 &' Where Id = & Id)
final sub
Sub Erro (STR) Selecione Case STR
Caso 1
Response.write <br> & nbsp; & nbsp; O mecanismo de pesquisa está vazio, entre em contato com <a href = Mailto: [email protected]> [email protected] </a>
Caso 2
Response.write <br> & nbsp; & nbsp; o nome do site está vazio, entre em contato com <a href = Mailto: [email protected]> [email protected] </a>
Caso 3
Response.write <br> & nbsp; & nbsp; O mecanismo de pesquisa que você inseriu não é suportado por este programa, entre em contato com <a href = Mailto: [email protected]> [email protected] </a> </body> < /html>
Caso 4
Response.write <br> & nbsp; & nbsp; erro desconhecido - os dados não podem ser rastejados, por favor <font color = blue> <a href = javascript: location.reload ();> refresh </a> </font> tente novamente < /Body> </html>
final Selecione
resposta.END
END SUBSUB Google (Strurl, id, todos) url = http: //www.google.cn/search? Complete = 1 & hl = zh-cn & q = site%3a & strurl && meta =
str = Gethttppage (URL)
se str = então
Conn.Execute (atualizar WebTable Set Google = '0' onde id = & id)
outro
SET REG = NOVO REGEXP
Reg.multiline = true
reg.global = false
Reg.ignorecase = true
str_top = <td alinhe = agora reproduza> <font size = -1>
str_bottom = </font> </td> </tr> </tabela>
reg.pattern = & str_top & ((.)*) e str_bottom &
SET MOCHES = REG.EXECUTE (STR)
Para cada correspondência1 em partidas
str = Match1.Value
Próximo
Set Matches = nada
Se Instr (str, <html>) = 1 então
str2 = 0
outro
str = dividido (str, </b>)
str1 = str (3)
str2 = divisão (str1, <b>) (1)
final se
Se Str2 = ou Len (STR2)> 200 Então
Conn.Execute (atualizar WebTable Set Google = '0' onde id = & id)
outro
Conn.Execute (Atualizar WebTable Set Google = '& Str2 &' Where Id = & Id)
final se
final se
Subsubs final Baidu (str, id, todos) 'Call Print_do (Baidu) se tudo = n então
url = http: //www.baidu.com/s? wd = site%3a & str && cl = 3
outro
Strext = Split (STR,.)
url = http: //www.baidu.com/s? wd = & strext (0) && cl = 3
final se
'Response.Write (<br> URL de Baidu: & url) se isobjinstalled (asphttp.conn) = true então
str = getasphttppage (url)
outro
str = Gethttppage (URL)
Final se
se str = então
Erro de chamada (4)
outro
SET REG = NOVO REGEXP
Reg.multiline = true
reg.global = false
Reg.ignorecase = true
str_top = <td alinhe = agorap>
str_bottom = </td>
reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
SET MOCHES = REG.EXECUTE (STR)
Para cada correspondência1 em partidas
str = Match1.Value
Próximo
Set Matches = nada
SET REG = NOTHORESPONSEIRO.WRITE <BR>
'Response.write & nbsp; & nbsp;
se str = ou len (str)> 200 então
Conn.Execute (Atualizar WebTable Set Baidu = '0' onde ID = & ID)
outro
Se Instr (STR, aproximadamente) = 0 então
keyw = página
outro
keyw = aproximado
final se
STR = MID (STR, (Instr (STR, Keyw) +1), (Instr (STR, Artigo) -Instr (STR, Keyw) -1))
Response.Write str
Conn.Execute (Atualizar WebTable Set Baidu = '& Substituir (substituir (str ,,,) ,,) e' onde id = & id)
final se
final se
Subsub Alexa final (Strurl, ID)
url = http: //www.alexa.com/data/details/traffic_details? q = & url = & strurl
Set r = server.createObject (microsoft.xmlhttp)
R.open get, url, falso,
R.SetRequestHeader Referent, Url
R.Send
str1 = bytes2bstr (R.Responsebody)
str1 = substituir (str1 ,,,)
SET REG = NOVO REGEXP
Reg.multiline = true
reg.global = true
Reg.ignorecase = true
str_top = <!-você sabia
str_bottom = </span> <br>
reg.pattern = & str_top & ((. |/n)*?) & str_bottom &
SET MOCHES = REG.EXECUTE (STR1)
str1 =
Para cada correspondência1 em partidas
str1 = str1 e match1.value
Próximo
Set Matches = nada
Definir reg = nada
str1 = substitua (str1, <!-você sabia?
Se str1 <> então
str1 = substituir (str1, <classe span,)
str1 = substituir (str1, </span> </span>,)
str1 = substituir (str1 ,,)
str1 = substituir (str1 ,,)
str1 = divisão (str1, <br>) (0)
Se cstr (direita (str1,7)) = </span> então
STR1 = esquerda (Trim (STR1), LEN (STR1) -7)
final se
Se fornumérico (STR1) então
num = str1
outro
csstxt = getalexacss ()
num =
str1 = divisão (str1, </span>)
para i = 0 para ubund (str1)
str2 = str1 (i)
se esquerdo (str2, instrum (str2, =)) <> então
num = num & esquerda (str2, instrum (str2, =)-1)
str2 = direita (str2, len (str2) -Instr (str2, =))
final se
str3 = dividido (str2,>)
para j = 0 para ubund (str3)
próximo
Se STR3 (0) <> então
se não é numérico (str3 (0)) então
Se Instr (CSSTXT, STR3 (0)) = 0 Então
num = num & str3 (1)
final se
final se
final se
próximo
final se
outro
num = 0
final se
SQL = Atualizar WebTable Set Alexa = '& num &' Where id = & id
Response.write (<cript> alert ('& sql &') </cript>)
Conn.Execute (SQL)
Subfunção final B2S (STR)
Dim o
Set o = server.createObject (adodb.stream)
O.Type = 1
O.Mode = 3
O.Open
O.WRITE STR
O.Position = 0
O.Type = 2
O.Charset = GB2312
B2S = O.readText
O.Close
Definir o = nada
Função final 'Pegue a folha de estilo de Alexa
Função getalexacss ()
url = http: //client.alexa.com/common/css/scramble.css
Se isobjinstalled (asphttp.conn) = true então
str = getasphttppage (url)
outro
str = Gethttppage (URL)
Final se
Getalexacss = str
Função final Print_do (STR)
Response.Write <Cript>
Response.Write function hiddenload ()
Response.Write {
Response.Write parent.do & str & .style.display = 'nenhum';
Response.write}
Response.Write </sCript>
Response.write <Body LeftMargin = 0 topMargin = 0 marginwidth = 0 marginHeight = 0 bgcolor =#f2f2f2 onload = hiddenload ()>
Subfunção final Gethttppage (URL)
em erro de erro em seguida
Dim http
Definir http = server.createObject (Microsoft.xmlHttp)
Http.open get, url, falso
Http.send ()
Se http.readyState <> 4 então
função de saída
final se
gethttppage = bytes2bst (http.Responsebody)
Defina http = nada
se err.number <> 0, então err.clear
Função final Função 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
Definido bytesstream = nada
Bytes2BSTR = StringReturn
Função final Getasphttppage (URL)
se url = então
função de saída
final se
Definir httpobj = server.createObject (asphttp.conn)
'Configure um servidor proxy, usuários que usam o proxy para acessar a Internet precisam definir esta opção
Se proxyip = 1 então
Httpobj.proxy = 192.168.5.254: 808
final se
Httpobj.timeout = 45
Httpobj.url = url
Httpobj.requestmethod = get
getApTtppage = httpobj.geturl
Definir httpobj = nada
Função final Função ISOBJinstala (strclassString)
Em erro de erro em seguida
Isobjinstalled = false
Err = 0
Dim XteSTOBJ
Definir xtestObj = server.createObject (strclassString) se 0 = err então então
Se asphttpopen = 1 então
Isobjinstalled = true
'Response.Write Current Component ASPHTTP
Outro
Isobjinstalled = false
'Response.Write Componente atual XMLHTTP
Final se
Outro
Isobjinstalled = false
'Response.Write Componente atual XMLHTTP
Final se definido XTestObj = nada
Err = 0
Função final