Um programa ladrão Alexa relativamente simples. Amigos que gostam desta função podem aprender seus princípios, acredito que você poderá escrever este programa em breve.
'Para apoiar a originalidade, por favor, mantenha este comentário, obrigado!
'Autor: Fei Caoshang
'Obtenha o nome de domínio principal
Função getDomainUrl(url)
tempurl=substituir(url,http://,)
se instr(tempurl,/)>0 então
tempurl=esquerda(tempurl,instr(tempurl,/)-1)
fimSe
getDomainurl=tempurl
Função final
Função GetHttpPage(HttpUrl)
Se IsNull(HttpUrl)=True Ou Len(HttpUrl)<18 Ou HttpUrl=$False$ Então
GetHttpPage=$Falso$
Função de saída
Terminar se
Dim HTTP
Definir Http=server.createobject(MSXML2.XMLHTTP)
Http.open GET,HttpUrl,Falso
Http.Enviar()
Se Http.Readystate<>4 então
Definir Http=Nada
GetHttpPage=$Falso$
Função de saída
Terminar se
GetHTTPage=Http.responseText
Definir Http=Nada
Se Err.número<>0 então
Err.Limpar
Terminar se
Função final
'================================================ = =
'Nome da função: ScriptHtml
'Função: filtrar tags HTML
'Parâmetro: ConStr ------ A string a ser filtrada
'TagName ------A tag a ser filtrada
' FType 1 significa filtrar o rótulo esquerdo, 2 significa filtrar os rótulos esquerdo e direito e o valor do meio 3 significa filtrar o rótulo esquerdo e o rótulo direito, retendo o conteúdo.
'================================================ = =
Função ScriptHtml(Byval ConStr,TagName,FType,includestr)
Dim Re
Definir Re = novo RegExp
Re.IgnoreCase=true
Re.Global = Verdadeiro
Selecione o tipo F do caso
Caso 1
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>
ConStr=Re.Replace(ConStr,)
Caso 2
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>.*?</ & TagName & ([^>])*>
'response.write construção&<br>
ConStr=Re.Replace(ConStr,)
'response.write server.htmlencode(constr)&<br>
Caso 3
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>
ConStr=Re.Replace(ConStr,)
Re.Pattern=</ & TagName & ([^>])*>
ConStr=Re.Replace(ConStr,)
Finalizar seleção
ScriptHtml=ConStr
Definir Re=Nada
Função final
'================================================ = =
'Nome da função: GetBody
'Função: interceptar string
'Parâmetro: ConStr ------A string a ser interceptada
'Parâmetro: StartStr ------string de início
'Parâmetro: OverStr ------Fim da string
'Parâmetro: IncluL ------Se StartStr está incluído
'Parâmetro:IncluR ------se deve incluir OverStr
'================================================ = =
Função GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
Se ConStr=$False$ ou ConStr= ou IsNull(ConStr)=True Ou StartStr= ou IsNull(StartStr)=True Ou OverStr= ou IsNull(OverStr)=True Então
ObterBody=$Falso$
Função de saída
Terminar se
DimConStrTemp
Dim Início, Fim
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Iniciar = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
'response.write Iniciar&<br>&IncluL&<br>
'resposta.fim
Se Iniciar<=0 então
ObterBody=$Falso$
Função de saída
Outro
Se IncluL=Falso então
Iniciar=Iniciar+LenB(StartStr)
Terminar se
Terminar se
Over=InStrB(Iniciar,ConStrTemp,OverStr,vbBinaryCompare)
'resposta.write Over
'resposta.fim
'response.write Iniciar& &Over& &Over-Start
'resposta.fim
Se Over<=0 ou Over<=Iniciar então
ObterBody=$Falso$
Função de saída
Outro
Se InclR = Verdadeiro então
Sobre=Sobre+LenB(OverStr)
Terminar se
Terminar se
GetBody=MidB(ConStr,Início,Over-Início)
'resposta.write getBody
'resposta.fim
Função final
'================================================ = =
'Nome da função: GetArray
'Função: Extraia o endereço do link, separado por $Array$
'Parâmetro: ConStr ------ Extrai os caracteres originais do endereço
'Parâmetro: StartStr ------string de início
'Parâmetro: OverStr ------Fim da string
'Parâmetro: IncluL ------Se StartStr está incluído
'Parâmetro:IncluR ------se deve incluir OverStr
'================================================ = =
Função GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Se ConStr=$False$ ou ConStr= Ou IsNull(ConStr)=True ou StartStr= Ou OverStr= ou IsNull(StartStr)=True Ou IsNull(OverStr)=True Então
GetArray=$Falso$
Função de saída
Terminar se
Dim TempStr,TempStr2,objRegExp,Correspondências,Correspondência
TempStr=
Definir objRegExp = Novo Regexp
objRegExp.IgnoreCase = Verdadeiro
objRegExp.Global = Verdadeiro
objRegExp.Pattern = (&StartStr&).+?(&OverStr&)
Definir correspondências =objRegExp.Execute(ConStr)
Para cada partida nas partidas
TempStr=TempStr & $Array$ & Match.Value
Próximo
Definir correspondências = nada
Se TempStr = Então
GetArray=$Falso$
Função de saída
Terminar se
TempStr=Direita(TempStr,Len(TempStr)-7)
Se IncluL=Falso então
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,)
Terminar se
Se InclR=Falso então
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,)
Terminar se
Definir objRegExp = nada
Definir correspondências = nada
Se TempStr = então
GetArray=$Falso$
Outro
GetArray=TempStr
Terminar se
Função final
Função getAlexaRank(weburl)
tempurl=getDomainUrl(weburl)
'Leia os dados em http://client.alexa.com/common/css/scramble.css
alexacss=http://client.alexa.com/common/css/scramble.css
strAlexaCss=GetHttpPage(alexacss)
'response.write strAlexaCss
'resposta.fim
alexarankqueryurl=http://www.alexa.com/data/details/traffic_details/&tempurl
strAlexaContent=GetHttpPage(alexarankqueryurl)
rankcontent=getBody(strAlexaContent,Information Service.-->,<!-- google_ad_section_end(name=default) -->,false,false)
'Pegue a classe span
strspan=GetArray(rankcontent,<span class=,,false,false)
'response.write classificaçãocontent&<br>
'response.write strspan&<br>
'resposta.fim
Se strspan<>$False$ Então
aspan=dividir(strspan,$Array$)
Para i = 0 para UBound (aspan)
'response.write .&aspan(i)
'Determine se aspan(i), a classe do span, existe no alexacss. Se existir, você precisa remover o span e os dados do span.
Se InStr(strAlexaCss,.&aspan(i))>=1 Então
'resposta.write aspan(i)&<br>
'resposta.fim
'Indica que o atributo não é nenhum e precisa ser substituído.
rankcontent=ScriptHtml(rankcontent,span,2,aspan(i))
Outro
rankcontent=ScriptHtml(rankcontent,span,1,aspan(i))
Terminar se
Próximo
'Substitua a tag span à direita que foi removida acima.
rankcontent=Substituir(rankcontent,</span>,)
Terminar se
Se rankcontent=$False$ Então
rankcontent=Sem dados
Terminar se
getAlexaRank=Substituir(classificarconteúdo,,,)
Função final
url=request.querystring(url)
%>
<nome do formulário = método alexaform = get>
URL de entrada:<tipo de entrada= nome=url valor=<%=url%> tamanho=40> <tipo de entrada=enviar valor=query>
</form>
<%
Se url<> Então
response.write A classificação ALEXA do seu site é:
resposta.flush
classificação=getAlexaRank(url)
classificação de resposta.write
Terminar se
%>