Après avoir étudié pendant deux jours, j'ai créé le code suivant et je l'ai partagé avec chaque collègue. Les données rampant ne sont pas correctes.
Set r = server.createObject (Microsoft.xmlhttp)
R.Open Get, URL, FALSE,
R.SetRequestHeader Référer, URL
R.Send
str1 = b2s (R.Responsebody)
str1 = remplacer (str1 ,,,)
Définir Reg = nouveau 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 =
Pour chaque match1 en matchs
str1 = match1.value
Suivant
Set Matchs = Rien
Définir Reg = rien
str1 = remplacer (remplacer (str1, str_top,), str_bottom,)
Conn.ExECUTE (Mettre à jour le set WebTable Set Pr = '& Str1 &' WHERE ID = & ID)
Sub-Sub
Sous-erreur (str) Sélectionner le cas Str
cas 1
réponse.write <br> & nbsp; & nbsp; Le moteur de recherche est vide, veuillez contacter <a href = mailto: [email protected]> [email protected] </a>
cas 2
Response.Write <br> & nbsp; & nbsp; Le nom du site est vide, veuillez contacter <a href = mailto: [email protected]> [email protected] </a>
cas 3
réponse.write <br> & nbsp; & nbsp; Le moteur de recherche que vous avez entré n'est pas pris en charge par ce programme, veuillez contacter <a href = Mailto: [email protected]> [email protected] </a> </body> < / html>
cas 4
Response.Write <br> & nbsp; & nbsp; Erreur inconnue - les données ne peuvent pas être rampées, s'il vous plaît <font color = bleu> <a href = javascript: location.reload ();> rafraîchir </a> </font> Ressinz à nouveau < / corps> </html>
fin de sélection
réponse.
End subsub google (strurl, id, all) url = http: //www.google.cn/search? Complete = 1 & hl = zh-cn & q = site% 3a & strurl && meta =
str = gethttppage (URL)
Si str = alors
Conn.ExECUTE (Mettre à jour WebTable set google = '0' où id = & id)
autre
Définir Reg = nouveau regexp
reg.multiline = true
reg.global = false
reg.ignorecase = true
str_top = <td align = en cecidrap> <font size = -1>
str_bottom = </font> </td> </tr> </ table>
reg.pattern = & str_top & ((.) *) & str_bottom &
Set Matchs = reg.execute (str)
Pour chaque match1 en matchs
str = match1.value
Suivant
Set Matchs = Rien
Si instr (str, <html>) = 1 alors
str2 = 0
autre
str = Split (str, </b>)
str1 = str (3)
str2 = division (str1, <b>) (1)
terminer si
Si str2 = ou len (str2)> 200 alors
Conn.ExECUTE (Mettre à jour WebTable set google = '0' où id = & id)
autre
Conn.Exécute (Mettre à jour WebTable set google = '& str2 &' où id = & id)
terminer si
terminer si
End subsub baidu (str, id, all) 'call print_do (baidu) si tout = n alors
url = http: //www.baidu.com/s? wd = site% 3a & str && cl = 3
autre
Strext = Split (Str ,.)
url = http: //www.baidu.com/s? wd = & strext (0) && cl = 3
terminer si
'Response.Write (<br> URL de Baidu: & URL) Si isOBJinStalled (asphttp.conn) = true alors
str = getasphttppage (URL)
autre
str = gethttppage (URL)
Terminer si
Si str = alors
Erreur d'appel (4)
autre
Définir Reg = nouveau regexp
reg.multiline = true
reg.global = false
reg.ignorecase = true
str_top = <td align = en ce moment
str_bottom = </td>
reg.pattern = & str_top & ((. | / n) *?) & str_bottom &
Set Matchs = reg.execute (str)
Pour chaque match1 en matchs
str = match1.value
Suivant
Set Matchs = Rien
SET REG = NothingResponse.Write <br>
'réponse.write & nbsp; & nbsp;
Si str = ou len (str)> 200 alors
Conn.Exécute (Mettre à jour WebTable set baidu = '0' où id = & id)
autre
Si instr (str, approximativement) = 0 alors
keyw = page
autre
keyw = approximation
terminer si
str = mid (str, (instant (str, keyw) +1), (instr (str, article) -instr (str, keyw) -1)))
réponse.WRITE STR
Conn.Execute (Update WebTable set baidu = '& remplacer (remplacer (str ,,,,) ,,) &' où id = & id)
terminer si
terminer si
Fin 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,
R.SetRequestHeader Référer, URL
R.Send
str1 = bytes2bstr (R.ResponseBody)
str1 = remplacer (str1 ,,,)
Définir Reg = nouveau regexp
reg.multiline = true
reg.global = true
reg.ignorecase = true
str_top = <! - Saviez-vous
str_bottom = </span> <br>
reg.pattern = & str_top & ((. | / n) *?) & str_bottom &
Set Matches = Reg.Execute (STR1)
str1 =
Pour chaque match1 en matchs
str1 = str1 & match1.value
Suivant
Set Matchs = Rien
Définir Reg = rien
Str1 = Remplacer (Str1, <! - Saviez-vous? Alexa propose ces données par programme. Visitez http://aws.amazon.com/awis pour plus d'informations sur le service d'information Web Alexa .-->,)
Si str1 <> alors
str1 = remplacer (str1, <class de span,)
str1 = remplacer (str1, </span> </span>,)
str1 = remplacer (str1 ,,)
str1 = remplacer (str1 ,,)
Str1 = Split (Str1, <br>) (0)
Si CSTR (droite (str1,7)) = </span> alors
str1 = gauche (trim (str1), len (str1) -7)
terminer si
Si ISNUMERIC (STR1) alors
num = str1
autre
csstxt = getAlexacss ()
num =
str1 = fendre (str1, </span>)
pour i = 0 à ubund (str1)
str2 = str1 (i)
Si vous êtes laissé (str2, instr (str2, =)) <> alors
num = num & gauche (str2, instr (str2, =) - 1)
str2 = droite (str2, len (str2) -instr (str2, =))
terminer si
str3 = fendre (str2,>)
pour j = 0 à Ubund (str3)
suivant
Si str3 (0) <> alors
Sinon ISNUMERIER (STR3 (0)) alors
Si instr (csstxt, str3 (0)) = 0 alors
num = num & str3 (1)
terminer si
terminer si
terminer si
suivant
terminer si
autre
num = 0
terminer si
sql = mise à jour webtable set alexa = '& num &' où id = & id
réponse.Write (<Script> alert ('& sql &') </cript>)
Conn.execute (SQL)
Sous-fonction finale B2S (STR)
Sombre o
Set o = server.createObject (adodb.stream)
O.Type = 1
O.Mode = 3
Open
O.Write Str
O.Position = 0
O.Type = 2
O.Charset = GB2312
B2s = o.readText
O.Close
Définir O = rien
Fonction finale 'Obtenez la feuille de style d'Alexa
Fonction getalexacss ()
url = http: //client.alexa.com/common/css/scramble.css
Si isObjinStalled (asphttp.Conn) = true alors
str = getasphttppage (URL)
autre
str = gethttppage (URL)
Terminer si
Getalexacss = str
Fonction de fin print_do (str)
réponse.Write <Script>
Response.Write Fonction HiddenLoad ()
réponse.write {
réponse.write parent.do & str & .style.display = 'Aucun';
réponse.write}
réponse.write </cript>
Response.Write <Body LeftMargin = 0 topMargin = 0 marginwidth = 0 marginheight = 0 bgColor = # f2f2f2 onload = HiddenLoad ()>
SUBUTUTION FIN GETHTTPPAGE (URL)
sur l'erreur reprendre ensuite
DIM HTTP
Définir http = server.createObject (Microsoft.xmlhttp)
Http.open get, url, false
Http.send ()
Si http.readystate <> 4 alors
fonction de sortie
terminer si
GethTTPPAGE = BYTES2BSTR (Http.ResponseBody)
définir http = rien
Si err.number <> 0 alors err.clear
Fonction finale Fonction Bytes2BST (VIN)
Dim BytesStream, Stringreturn
Set bytesStream = server.createObject (Adodb.stream)
BytesStream.Type = 2
Bytestream.open
BytesStream.WriteText Vin
BytesStream.Position = 0
BytesStream.Charset = GB2312
BytesStream.Position = 2
StringReturn = bytesStream.readText
Bytestream.close
Set BytesStream = Rien
Bytes2bstr = stringreturn
Fin functionfunction getasphttppage (URL)
Si url = alors
fonction de sortie
terminer si
Définir httpobj = server.createObject (asphttp.conn)
'Configurer un serveur proxy, les utilisateurs qui utilisent le proxy pour accéder à Internet doivent définir cette option
Si proxyip = 1 alors
Httpobj.proxy = 192.168.5.254: 808
terminer si
Httpobj.timeout = 45
Httpobj.url = url
Httpobj.requestMethod = obtenir
getaphTTPPAGE = httpobj.getUrl
définir httpobj = rien
Fonction finale Fonction Isobjinstalled (StrClassString)
Sur l'erreur reprendre ensuite
IsObjinstalled = false
Err = 0
Dim xttestobj
Set xtTestObj = server.createObject (strClassString) si 0 = err alors
Si asphttpopen = 1 alors
IsObjinStalled = true
'Response.Write Composant actuel Asphttp
Autre
IsObjinstalled = false
'Réponse.Write Composant actuel XMLHTTP
Terminer si
Autre
IsObjinstalled = false
'Réponse.Write Composant actuel XMLHTTP
Fin si définissez xtTestObj = rien
Err = 0
Fonction finale