Este artigo fornece um conjunto completo de funções de coleta ASP, incluindo funções como extrair os caracteres originais do endereço, salvar arquivos remotos em login simulado local e obter o código-fonte da página da web.
Copie o código do código da seguinte forma:
'================================================ = =
'Nome da função: GetHttpPage
'Função: Obtenha o código fonte da página web
'Parâmetro: HttpUrl ------Endereço da página da web
'================================================ = =
Função GetHttpPage(HttpUrl)
Se IsNull(HttpUrl)=True Ou Len(HttpUrl)<18 Ou HttpUrl="$False$" Então
GetHttpPage="$False$"
Função de saída
Terminar se
Dim HTTP
Defina Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET",HttpUrl,Falso
Http.Enviar()
Se Http.Readystate<>4 então
Definir Http=Nada
GetHttpPage="$False$"
Função de saída
Terminar se
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Definir Http=Nada
Se Err.número<>0 então
Err.Limpar
Terminar se
Função final
'================================================ = =
'Nome da função: BytesToBstr
'Função: Converte o código fonte obtido para chinês
'Parâmetro: Corpo ------Variável a ser convertida
'Parâmetro: Cset ------tipo a ser convertido
'================================================ = =
Função BytesToBstr(Body,Cset)
Escurecer Objstream
Definir Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Modo =3
objstream.Open
objstream.Escrever corpo
objstream.Posição = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Fechar
definir objstream = nada
Função final
'================================================ = =
'Nome da função: PostHttpPage
'Função: login
'================================================ = =
Função PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
Definir xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Open "POST", PostUrl, Falso
XmlHTTP.setRequestHeader "Comprimento do conteúdo",Len(PostData)
xmlHttp.setRequestHeader "Tipo de conteúdo", "aplicativo/x-www-form-urlencoded"
xmlHttp.setRequestHeader "Referer", RefererUrl
xmlHttp.Enviar PostData
Se Err.Number <> 0 Então
Definir xmlHttp=Nada
PostHttpPage = "$Falso$"
Função de saída
Terminar se
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Defina xmlHttp = nada
Função final
'================================================ = =
'Nome da função: UrlEncoding
'Função: Converter codificação
'================================================ = =
Função UrlEncoding(DataStr)
Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn = ""
Para Si = 1 para Len(DataStr)
EsteChr = Médio(DataStr,Si,1)
Se Abs(Asc(ThisChr)) < &HFF Então
StrReturn = StrReturn & ThisChr
Outro
InnerCode = Asc(ThisChr)
Se InnerCode <0 então
Código Interno = Código Interno + &H10000
Terminar se
Hight8 = (InnerCode e &HFF00)/&HFF
Baixo8 = InnerCode e &HFF
StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
Terminar se
Próximo
UrlEncoding = StrReturn
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 Or StartStr="" ou IsNull(StartStr)=True Or OverStr="" ou IsNull(OverStr)=True Então
GetBody="$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)
Se Iniciar<=0 então
GetBody="$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)
Se Over<=0 ou Over<=Iniciar então
GetBody="$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)
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
TempStr=Substituir(TempStr,"""","")
TempStr=Substituir(TempStr,"'","")
TempStr=Substituir(TempStr," ","")
TempStr=Substituir(TempStr,"(","")
TempStr=Substituir(TempStr,")","")
Se TempStr="" então
GetArray="$Falso$"
Outro
GetArray=TempStr
Terminar se
Função final
'================================================ = =
'Nome da função: DefiniteUrl
'Função: Converte endereço relativo em endereço absoluto
'Parâmetro: PrimitiveUrl ------ endereço relativo a ser convertido
'Parâmetro: ConsultUrl ------Endereço atual da página web
'================================================ = =
Função DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
Se PrimitiveUrl="" ou ConsultUrl="" ou PrimitiveUrl="$False$" ou ConsultUrl="$False$" Então
DefiniteUrl="$False$"
Função de saída
Terminar se
If Left(Lcase(ConsultUrl),7)<>"http://" Então
ConsultUrl= "http://" & ConsultUrl
Terminar se
ConsultUrl=Substituir(ConsultUrl,"/","/")
ConsultUrl=Replace(ConsultUrl,"://","://")
PrimitiveUrl=Substituir(PrimitiveUrl,"/","/")
If Right(ConsultUrl,1)<>"/" Então
Se Instr(ConsultUrl,"/")>0 Então
Se Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 então
Outro
ConsultUrl=ConsultarUrl & "/"
Terminar se
Outro
ConsultUrl=ConsultarUrl & "/"
Terminar se
Terminar se
ConArray=Dividir(ConsultarUrl,"/")
Se Left(LCase(PrimitiveUrl),7) = "http://" então
DefiniteUrl=Substituir(PrimitiveUrl,"://","://")
ElseIf Left(PrimitiveUrl,1) = "/" Então
DefiniteUrl=ConArray(0) e PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Direita(PrimitiveUrl,Len(PrimitiveUrl)-2)
Se estiver certo(ConsultUrl,1)="/" Então
DefiniteUrl = ConsultUrl e PrimitiveUrl
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Terminar se
ElseIf Left(PrimitiveUrl,3)="../"então
Faça enquanto à esquerda(PrimitiveUrl,3)="../"
PrimitiveUrl=Direito(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Laço
Para Ci=0 a (Ubound(ConArray)-1-Pi)
Se DefiniteUrl<>"" Então
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Outro
DefiniteUrl=ConArray(Ci)
Terminar se
Próximo
DefiniteUrl = DefiniteUrl & "/" & PrimitiveUrl
Outro
Se Instr(PrimitiveUrl,"/")>0 Então
PriArray=Split(PrimitiveUrl,"/")
Se Instr(PriArray(0),".")>0 Então
Se estiver certo(PrimitiveUrl,1)="/" Então
DefiniteUrl="http://" e PrimitiveUrl
Outro
Se Instr(PriArray(Ubound(PriArray)-1),".")>0 Então
DefiniteUrl="http://" e PrimitiveUrl
Outro
DefiniteUrl="http://" & PrimitiveUrl & "/"
Terminar se
Terminar se
Outro
Se estiver certo(ConsultUrl,1)="/" Então
DefiniteUrl = ConsultUrl e PrimitiveUrl
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Terminar se
Terminar se
Outro
Se Instr(PrimitiveUrl,".")>0 Então
Se estiver certo(ConsultUrl,1)="/" Então
Se right(LCase(PrimitiveUrl),3)=".cn" ou right(LCase(PrimitiveUrl),3)="com" ou right(LCase(PrimitiveUrl),3)="net" ou right(LCase(PrimitiveUrl) ,3)="org" Então
DefiniteUrl="http://" & PrimitiveUrl & "/"
Outro
DefiniteUrl = ConsultUrl e PrimitiveUrl
Terminar se
Outro
Se right(LCase(PrimitiveUrl),3)=".cn" ou right(LCase(PrimitiveUrl),3)="com" ou right(LCase(PrimitiveUrl),3)="net" ou right(LCase(PrimitiveUrl) ,3)="org" Então
DefiniteUrl="http://" & PrimitiveUrl & "/"
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
Terminar se
Terminar se
Outro
Se estiver certo(ConsultUrl,1)="/" Então
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
Terminar se
Terminar se
Terminar se
Terminar se
Se Left(DefiniteUrl,1)="/"então
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
Terminar se
Se DefiniteUrl<>"" Então
DefiniteUrl=Substituir(DefiniteUrl,"//","/")
DefiniteUrl=Substituir(DefiniteUrl,"://","://")
Outro
DefiniteUrl="$False$"
Terminar se
Função final
'================================================ = =
'Nome da função: ReplaceSaveRemoteFile
'Função: substituir e salvar imagens remotas
'Parâmetro: ConStr ------ string a ser substituída
'Parâmetro: SaveTf ------ Se deseja salvar o arquivo, False não salva, True salva
'Parâmetro: TistUrl------ endereço da página web atual
'================================================ = =
Função SubstituaSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
Se ConStr="$False$" ou ConStr="" ou InstallPath="" ou strChannelDir="" Então
SubstituaSaveRemoteFile=ConStr
Função de saída
Terminar se
Dim TempStr,TempStr2,TempStr3,Re,Correspondências,Correspondência,Tempi,TempArray,TempArray2
Definir Re = Novo Regexp
Re.IgnoreCase = Verdadeiro
Re.Global = Verdadeiro
Re.Pattern ="<img.+?>"
Definir correspondências =Re.Execute(ConStr)
Para cada partida nas partidas
Se TempStr<>"" então
TempStr=TempStr & "$Array$" & Match.Value
Outro
TempStr=Match.Value
Terminar se
Próximo
Se TempStr<>"" Então
TempArray=Dividir(TempStr,"$Array$")
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
Re.Pattern ="src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
Definir correspondências =Re.Execute(TempArray(Tempi))
Para cada partida nas partidas
Se TempStr<>"" então
TempStr=TempStr & "$Array$" & Match.Value
Outro
TempStr=Match.Value
Terminar se
Próximo
Próximo
Terminar se
Se TempStr<>"" Então
Re.Pattern ="src/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Terminar se
Definir correspondências = nada
Definir Re = nada
Se TempStr="" ou IsNull(TempStr)=True então
SubstituaSaveRemoteFile=ConStr
Função de saída
Terminar se
TempStr=Substituir(TempStr,"""","")
TempStr=Substituir(TempStr,"'","")
TempStr=Substituir(TempStr," ","")
Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtAgora=Agora()
'**********************************
Se SaveTf=True então
SavePath=InstallPath&strChannelDir
Se CheckDir(InstallPath & strChannelDir)=False então
Se não for CreateMultiFolder(InstallPath & strChannelDir) então
resposta.Write InstallPath & strChannelDir&"Falha na criação do diretório"
SalvarTf=Falso
Terminar se
Terminar se
Terminar se
'Comece removendo imagens duplicadas
TempArray=Dividir(TempStr,"$Array$")
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
Se Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Então
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Terminar se
Próximo
TempStr=Direita(TempStr,Len(TempStr)-7)
TempArray=Dividir(TempStr,"$Array$")
'Remove imagens duplicadas e finaliza
resposta.Write "<br>Imagem encontrada:<br>"&Replace(TempStr,"$Array$","<br>")
'Comece a converter endereços de imagens relativos
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Próximo
TempStr=Direita(TempStr,Len(TempStr)-7)
TempStr=Substituir(TempStr,Chr(0),"")
TempArray2=Dividir(TempStr,"$Array$")
TempStr=""
'Fim da conversão do endereço relativo da imagem
'Substituição/salvamento de imagem
Definir Re = Novo Regexp
Re.IgnoreCase = Verdadeiro
Re.Global = Verdadeiro
Para Tempi = 0 para Ubound (TempArray2)
'************************************
RemoteFileUrl=TempArray2(Tempi)
Se RemoteFileUrl<>"$False$" E SaveTf=True Então'Salve a imagem
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'Tipo de arquivo
Se strFileType="asp" ou strFileType="asa" ou strFileType="aspx" ou strFileType="cer" ou strFileType="cdx" ou strFileType="exe" ou strFileType="rar" ou strFileType="zip" então
CarregarArquivos=""
SubstituaSaveRemoteFile=ConStr
Função de saída
Terminar se
Randomizar
NumRan=Int(900*Rnd)+100
strNomeArquivo = ano(DtNow) & right("0" & mês(DtNow),2) & right("0" & dia(DtNow),2) & right("0" & hora(DtNow) ),2) & direita ("0" & minuto(DtNow),2) & direita("0" & segundo(DtNow),2) & ranNum & "."
Re.Pattern =TempArray(Tempi)
response.Write "<br>Salvar no endereço local:"&InstallPath & strChannelDir & strFileName
Se SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Então
resposta.Escreva "<font color=blue>Sucesso</font><br>"
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Outro
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
Terminar se
ElseIf RemoteFileurl<>"$False$" e SaveTf=False Then'Não salve a imagem
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Terminar se
'************************************
Próximo
Definir Re = nada
SubstituaSaveRemoteFile=ConStr
Função final
'================================================ = =
'Nome da função: ReplaceSwfFile
'Função: analisa o caminho da animação
'Parâmetro: ConStr ------ string a ser substituída
'Parâmetro: TistUrl------ endereço da página web atual
'================================================ = =
Função SubstituaSwfFile(ConStr,TistUrl)
Se ConStr="$False$" ou ConStr="" ou TistUrl="" ou TistUrl="$False$" Então
SubstituirSwfFile=ConStr
Função de saída
Terminar se
Dim TempStr,TempStr2,TempStr3,Re,Correspondências,Correspondência,Tempi,TempArray,TempArray2
Definir Re = Novo Regexp
Re.IgnoreCase = Verdadeiro
Re.Global = Verdadeiro
Re.Pattern ="<objeto.+?[^/>]>"
Definir correspondências =Re.Execute(ConStr)
Para cada partida nas partidas
Se TempStr<>"" então
TempStr=TempStr & "$Array$" & Match.Value
Outro
TempStr=Match.Value
Terminar se
Próximo
Se TempStr<>"" Então
TempArray=Dividir(TempStr,"$Array$")
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
Re.Pattern ="valor/s*=/s*.+?/.swf"
Definir correspondências =Re.Execute(TempArray(Tempi))
Para cada partida nas partidas
Se TempStr<>"" então
TempStr=TempStr & "$Array$" & Match.Value
Outro
TempStr=Match.Value
Terminar se
Próximo
Próximo
Terminar se
Se TempStr<>"" Então
Re.Pattern ="valor/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Terminar se
Se TempStr="" ou IsNull(TempStr)=True então
SubstituirSwfFile=ConStr
Função de saída
Terminar se
TempStr=Substituir(TempStr,"""","")
TempStr=Substituir(TempStr,"'","")
TempStr=Substituir(TempStr," ","")
Definir correspondências = nada
Definir Re = nada
'Comece removendo arquivos duplicados
TempArray=Dividir(TempStr,"$Array$")
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
Se Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Então
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Terminar se
Próximo
TempStr=Direita(TempStr,Len(TempStr)-7)
TempArray=Dividir(TempStr,"$Array$")
'Remova arquivos duplicados e finalize
'Comece a converter endereços relativos
TempStr=""
Para Tempi = 0 para Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Próximo
TempStr=Direita(TempStr,Len(TempStr)-7)
TempStr=Substituir(TempStr,Chr(0),"")
TempArray2=Dividir(TempStr,"$Array$")
TempStr=""
'Fim da conversão do endereço relativo
'substituir
Definir Re = Novo Regexp
Re.IgnoreCase = Verdadeiro
Re.Global = Verdadeiro
Para Tempi = 0 para Ubound (TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Próximo
Definir Re = nada
SubstituirSwfFile=ConStr
Função final
'================================================ = =
'Nome do processo: SaveRemoteFile
'Função: salvar arquivos remotos em local
'Parâmetro: LocalFileName ------ nome do arquivo local
'Parâmetro: RemoteFileUrl ------ URL do arquivo remoto
'Parâmetro: Referer ------ Arquivo de chamada remota (para anti-coleta, use o endereço da página de conteúdo, deixe em branco se não houver anti-coleta)
'================================================ = =
Função SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile = Verdadeiro
dim Anúncios, Recuperação, GetRemoteData
Definir recuperação = Server.CreateObject("Microsoft.XMLHTTP")
Com recuperação
.Abra "Obter", RemoteFileUrl, Falso, "", ""
if Referer<>"" então .setRequestHeader "Referer",Referer
.Enviar
Se .Readystate<>4 então
SaveRemoteFile=Falso
Função de saída
Terminar se
GetRemoteData = .ResponseBody
Terminar com
Definir recuperação = nada
Definir anúncios = Server.CreateObject("Adodb.Stream")
Com anúncios
.Tipo = 1
.Abrir
.Escreva GetRemoteData
.SaveToFile servidor.MapPath(LocalFileName),2
.Cancelar()
.Fechar()
Terminar com
Definir anúncios = nada
função final
'================================================ = =
'Nome da função: GetPaing
'Função: Obter paginação
'================================================ = =
Função GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Se ConStr="$False$" ou ConStr="" Ou StartStr="" Ou OverStr="" ou IsNull(ConStr)=True ou IsNull(StartStr)=True Ou IsNull(OverStr)=True Então
GetPaing="$Falso$"
Função de saída
Terminar se
Dim Start,Over,ConTemp,TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
SobreStr=LCase(OverStr)
Sobre=Instr(1,TempStr,OverStr)
Se acima de <= 0 então
GetPaing="$Falso$"
Função de saída
Outro
Se InclR = Verdadeiro então
Sobre=Sobre+Len(OverStr)
Terminar se
Terminar se
TempStr=Mid(TempStr,1,Over)
Iniciar=InstrRev(TempStr,StartStr)
Se IncluL=Falso então
Iniciar=Iniciar+Len(StartStr)
Terminar se
Se Iniciar<=0 ou Iniciar>=Over então
GetPaing="$Falso$"
Função de saída
Terminar se
ConTemp=Mid(ConStr,Início,Over-Início)
ConTemp=Cortar(ConTemp)
'ConTemp=Substituir(ConTemp," ","")
ConTemp=Substituir(ConTemp,",","")
ConTemp=Substituir(ConTemp,"'","")
ConTemp=Substituir(ConTemp,"""","")
ConTemp=Substituir(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp," ;","")
GetPaing=ConTemp
Função final
'************************************************
'Nome da função: gotTopic
'Função: truncar a string, cada caractere chinês conta como dois caracteres e o caractere inglês conta como um caractere
'Parâmetro: str ---- string original
' strlen ---- comprimento da interceptação
'Valor de retorno: string interceptada
'************************************************
função gotTopic(str,strlen)
se str="" então
gotTopic=""
função de saída
terminar se
escurecer l,t,c,i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
eu=len(str)
t=0
para eu = 1 para eu
c=Abs(Asc(Médio(str,i,1)))
se c>255 então
t=t+2
outro
t=t+1
terminar se
se t>=strlen então
gotTopic=esquerda(str,i) & "…"
saída para
outro
gotTopic=str
terminar se
próximo
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
função final
'*********************************************
'Nome da função: JoinChar
'Função: Adicionar ? ou & ao endereço
'Parâmetro: strUrl ---- URL
'Valor de retorno: URL com ? ou & adicionado
'*********************************************
função JoinChar(strUrl)
se strUrl="" então
JoinChar=""
função de saída
terminar se
if InStr(strUrl,"?")<len(strUrl) então
se InStr(strUrl,"?")>1 então
if InStr(strUrl,"&")<len(strUrl) então
JoinChar = strUrl & "&"
outro
JoinChar=strUrl
terminar se
outro
JoinChar = strUrl & "?"
terminar se
outro
JoinChar=strUrl
terminar se
função final
'**********************************************
'Nome da função: CreateKeyWord
'Função: Gera palavras-chave a partir da string fornecida
'Parâmetro: Constr---a string original para gerar a palavra-chave
'Valor de retorno: palavra-chave gerada
'**********************************************
Função CreateKeyWord(byval Constr,Num)
Se Constr="" ou IsNull(Constr)=True ou Constr="$False$" Então
CreateKeyWord="$False$"
Função de saída
Terminar se
Se Num="" ou IsNumeric(Num)=False então
Num = 2
Terminar se
Constr=Substituir(Constr,CHR(32),"")
Constr=Substituir(Constr,CHR(9),"")
Const=Substituir(Constr," ","")
Const=Substituir(Constr," ","")
Const=Substituir(Constr,"(","")
Const=Substituir(Constr,")","")
Constr=Substituir(Constr,"<","")
Const=Substituir(Constr,">","")
Const=Substituir(Constr,"""","")
Const=Substituir(Constr,"?","")
Const=Substituir(Constr,"*","")
Const=Substituir(Constr,"","")
Const=Substituir(Constr,",","")
Constr=Substituir(Constr,".","")
Const=Substituir(Constr,"/","")
Const=Substituir(Constr,"/","")
Const=Substituir(Constr,"-","")
Const=Substituir(Constr,"@","")
Const=Substituir(Constr,"#","")
Const=Substituir(Constr,"$","")
Const=Substituir(Constr,"%","")
Const=Substituir(Constr,"&","")
Const=Substituir(Constr,"+","")
Const=Substituir(Constr,":","")
Const=Substituir(Constr,"：","")
Const=Substituir(Constr,"'","")
Const=Substituir(Constr,""","")
Const=Substituir(Constr,""","")
Dim i,ConstrTemp
Para i=1 para Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Próximo
Se Len(ConstrTemp)<254 Então
ConstTemp=ConstrTemp & ""
Outro
ConstrTemp = Esquerda (ConstrTemp, 254) & ""
Terminar se
CreateKeyWord=ConstrTemp
Função final
'================================================ = =
'Nome da função: CheckUrl
'Função: Verificar URL
'Parâmetro: strUrl ------ Para verificar o URL
'================================================ = =
Função CheckUrl(strUrl)
Dim Re
Definir Re = novo RegExp
Re.IgnoreCase=true
Re.Global = Verdadeiro
Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"
Se Re.test(strUrl)=True Então
CheckUrl=strUrl
Outro
CheckUrl="$Falso$"
Terminar se
Definir Rs=Nada
Função final
'================================================ = =
'Nome da função: ScriptHtml
'Função: filtrar tags HTML
'Parâmetro: ConStr ------ A string a ser filtrada
'================================================ = =
Função ScriptHtml(Byval ConStr,TagName,FType)
Dim Re
Definir Re = novo RegExp
Re.IgnoreCase=true
Re.Global = Verdadeiro
Selecione o tipo F do caso
Caso 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Caso 2
Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Caso 3
Re.Pattern="<" & TagName & "([^>])*>"
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: RemoveHTML
'Função: Remover completamente tags HTML
'Parâmetro: strHTML ------ A string a ser filtrada
'================================================ = =
Função RemoveHTML(strHTML)
Dim objRegExp, Correspondência, Correspondências
Definir objRegExp = Novo Regexp
objRegExp.IgnoreCase = Verdadeiro
objRegExp.Global = Verdadeiro
'Feche o <>
objRegExp.Pattern = "<.+?>"
'Corresponder
Definir correspondências = objRegExp.Execute(strHTML)
'Percorre o conjunto correspondente e substitui os itens correspondentes
Para cada partida nas partidas
strHtml=Substituir(strHTML,Match.Value,"")
Próximo
RemoverHTML=strHTML
Definir objRegExp = Nada
Função final
'================================================ = =
'Nome da função: CheckDir
'Função: Verifica se a pasta existe
'Parâmetro: FolderPath ------ caminho da pasta
'================================================ = =
Função CheckDir (byval FolderPath)
escurecer fso
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.FolderExists(Server.MapPath(folderpath)) então
'existir
CheckDir = Verdadeiro
Outro
'não existe
CheckDir = Falso
Terminar se
Defina fso = nada
Função final
'================================================ = =
'Nome da função: MakeNewsDir
'Função: Criar uma pasta
'Parâmetro: nome da pasta ------ nome da pasta
'================================================ = =
Função MakeNewsDir(byval nome da pasta)
escurecer fso
Definir fso = Server.CreateObject ("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(nome da pasta))
Se fso.FolderExists(Server.MapPath(nome da pasta)) Então
MakeNewsDir = Verdadeiro
Outro
MakeNewsDir = Falso
Terminar se
Defina fso = nada
Função final
'================================================ = =
'Nome da função: DelDir
'Função: Criar uma pasta
'Parâmetro: nome da pasta ------ nome da pasta
'================================================ = =
Função DelDir (byval nome da pasta)
escurecer fso
Definir fso = Server.CreateObject ("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If fso.FolderExists(Server.MapPath(foldername)) Then 'Determine se a pasta existe
fso.DeleteFolder (Server.MapPath(nome da pasta)) 'Excluir pasta
Terminar se
Defina fso = nada
Função final
'**********************************************
'Nome da função: IsObjInstalled
'Função: Verifique se o componente foi instalado
'Parâmetro: strClassString ---- nome do componente
'Valor de retorno: True ---- Já instalado
'Falso ---- não instalado
'**********************************************
Função IsObjInstalled(strClassString)
IsObjInstalled = Falso
Errar = 0
DimxTestObj
Definir xTestObj = Server.CreateObject(strClassString)
Se 0 = Err Então IsObjInstalled = True
Definir xTestObj = Nada
Errar = 0
Função final
'**********************************************
'Nome da função: strLength
'Função: Encontre o comprimento da string. Os caracteres chineses contam como dois caracteres e os caracteres ingleses contam como um caractere.
'Parâmetro: str ----String com comprimento necessário
'Valor de retorno: comprimento da string
'**********************************************
função strComprimento(str)
EM ERRO RETOMAR PRÓXIMO
escurecer WINNT_CHINESE
WINNT_CHINESE = (len("China")=2)
se WINNT_CHINESE então
escurecer l,t,c
escurecer eu
eu=len(str)
t = eu
para eu = 1 para eu
c=asc(meio(str,i,1))
se c<0 então c=c+65536
se c>255 então
t=t+1
terminar se
próximo
strComprimento=t
outro
strComprimento=len(str)
terminar se
se err.número<>0 então err.clear
função final
'********************************************** **
'Nome da função: CreateMultiFolder
'Função: Crie diretórios multiníveis, você pode criar diretórios raiz inexistentes
'Parâmetro: o nome do diretório a ser criado, que pode ser multinível
'Valor lógico de retorno: True em caso de sucesso, False em caso de falha
'Cria o diretório raiz do diretório começando no diretório atual
'********************************************** **
Função CreateMultiFolder(ByVal CFolder)
Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo=Falso
CriarPasta = CFfolder
Em caso de erro, retomar o próximo
Definir objFSO = Server.CreateObject ("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
Se errar então
Err.Limpar()
Função de saída
Terminar se
CreateFolder = Substituir(CreateFolder,"/","/")
If Left(CreateFolder,1)="/" Então
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
Terminar se
If Right(CreateFolder,1)="/" Então
CreateFolder = Esquerda(CreateFolder,Len(CreateFolder)-1)
Terminar se
CreateFolderArray = Dividir(CreateFolder,"/")
Para i = 0 para UBound (CreateFolderArray)
CreateFolderSub = ""
Para ii = 0 para eu
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Próximo
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'resposta.Write PhCreateFolderSub&"<br>"
Se não objFSO.FolderExists (PhCreateFolderSub) então
objFSO.CreateFolder(PhCreateFolderSub)
Terminar se
Próximo
Se errar então
Err.Limpar()
Outro
BlInfo=Verdadeiro
Terminar se
Definir objFSO = nada
CriarMultiFolder = BlInfo
Função final
'**********************************************
'Nome da função: FSOFileRead
'Função: Use FSO para ler a função de conteúdo do arquivo
'Parâmetro: nome do arquivo ---- nome do arquivo
'Valor de retorno: conteúdo do arquivo
'**********************************************
função FSOFileRead(nome do arquivo)
Dim objFSO,objCountFile,FiletempData
Definir objFSO = Server.CreateObject("Scripting.FileSystemObject")
Definir objCountFile = objFSO.OpenTextFile(Server.MapPath(nome do arquivo),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Definir objCountFile=Nada
Definir objFSO = Nada
Função final
'**********************************************
'Nome da função: FSOlineedit
'Função: Use FSO para ler uma determinada linha da função de arquivo
'Parâmetro: nome do arquivo ---- nome do arquivo
'lineNum ----número da linha
'Valor de retorno: o conteúdo da linha no arquivo
'**********************************************
função FSOlinedit(nome do arquivo,NumLinha)
se linenum <1 então saia da função
dim fso,f,temparray,tempcnt
definir fso = server.CreateObject("scripting.filesystemobject")
se não fso.fileExists(server.mappath(filename)) então saia da função
definir f = fso.opentextfile(server.mappath(nome do arquivo),1)
se não for f.AtEndofStream então
tempcnt = f.readall
f.fechar
definir f = nada
temparray = dividir(tempcnt,chr(13)&chr(10))
se lineNum>ubound(temparray)+1 então
função de saída
outro
FSOlineedit = temparray(lineNum-1)
terminar se
terminar se
função final
'**********************************************
'Nome da função: FSOlinewrite
'Função: Use FSO para escrever uma determinada linha da função de arquivo
'Parâmetro: nome do arquivo ---- nome do arquivo
'lineNum ----número da linha
'Conteúdo da linha ---- conteúdo
'Valor de retorno: Nenhum
'**********************************************
função FSOlinewrite(nome do arquivo,lineNum,Linecontent)
se linenum <1 então saia da função
dim fso,f,temparray,tempCnt
definir fso = server.CreateObject("scripting.filesystemobject")
se não fso.fileExists(server.mappath(filename)) então saia da função
definir f = fso.opentextfile(server.mappath(nome do arquivo),1)
se não for f.AtEndofStream então
tempcnt = f.readall
f.fechar
temparray = divisão(tempcnt,chr(13)&chr(10))
se lineNum>ubound(temparray)+1 então
função de saída
outro
temparray(lineNum-1) = lineContent
terminar se
tempcnt = join(temparray,chr(13)&chr(10))
definir f = fso.createtextfile(server.mappath(nome do arquivo),true)
f.writetempcnt
terminar se
f.fechar
definir f = nada
função final
'**********************************************
'Nome da função: Htmlmake
'Função: Usar FSO para criar arquivos
'Parâmetro: HtmlFolder ---- caminho
' HtmlFilename ---- nome do arquivo
'HtmlContent ----Conteúdo
'**********************************************
função Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
Em caso de erro, retomar o próximo
dim caminho do arquivo,fso,fout
caminho do arquivo = HtmlFolder&"/"&HtmlFilename
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.FolderExists(HtmlFolder) Então
Outro
CriarMultiFolder(HtmlFolder)
&, ;nbs, p;
Defina fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fout.fechar
definir fso = nada
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.fileexists(Server.MapPath(filepath)) Então
Response.Write "Arquivo<font color=red>"&HtmlFilename&"</font> foi gerado!<br>"
Outro
'Response.Write Server.MapPath(caminho do arquivo)
Response.Write "Arquivo<font color=red>"&HtmlFilename&"</font> não foi gerado!<br>"
Terminar se
Defina fso = nada
Função final
'**********************************************
'Nome da função: Htmldel
'Função: Use FSO para deletar arquivos
'Parâmetro: HtmlFolder ---- caminho
' HtmlFilename ---- nome do arquivo
'**********************************************
SubHtmldel(HtmlFolder,HtmlFilename)
dim caminho do arquivo,fso
caminho do arquivo = HtmlFolder&"/"&HtmlFilename
Definir fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(caminho do arquivo))
Defina fso = nada
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.fileexists(Server.MapPath(filepath)) Então
Response.Write "Arquivo<font color=red>"&HtmlFilename&"</font> não foi excluído!<br>"
Outro
'Response.Write Server.MapPath(caminho do arquivo)
Response.Write "Arquivo<font color=red>"&HtmlFilename&"</font> foi excluído!<br>"
Terminar se
Defina fso = nada
Finalizar sub
'================================================ =
'Nome do processo: HTMLEncode
'Função: filtrar formato HTML
'Parâmetro: fString ----Conteúdo de conversão
'================================================ =
função HTMLEncode(ByVal fString)
Se IsNull(fString)=False ou fString<>"" ou fString<>"$False$" Então
fString = Substituir(fString, ">", ">")
fString = Substituir(fString, "<", "<")
fString = Substituir(fString, Chr(32), " ")
fString = Substituir(fString, Chr(9), " ")
fString = Substituir(fString, Chr(34), """)
fString = Substituir(fString, Chr(39), "'")
fString = Substituir(fString, Chr(13), "")
fString = Substituir(fString, " ", " ")
fString = Substituir(fString, CHR(10) & CHR(10), "</P><P>")
fString = Substituir(fString, Chr(10), "<br /> ")
HTMLEncode=fString
outro
HTMLEncode = "$Falso$"
terminar se
função final
'================================================ =
'Nome do processo: unHTMLEncode
'Função: restaurar formato HTML
'Parâmetro: fString ----Conteúdo de conversão
'================================================ =
função unHTMLEncode(ByVal fString)
Se IsNull(fString)=False ou fString<>"" ou fString<>"$False$" Então
fString = Substituir(fString, ">", ">")
fString = Substituir(fString, "<", "<")
fString = Substituir(fString, " ", Chr(32))
fString = Substituir(fString, """, Chr(34))
fString = Substituir(fString, "'", Chr(39))
fString = Substituir(fString, "", Chr(13))
fString = Substituir(fString, " ", " ")
fString = Substituir(fString, "</P><P>" , CHR(10) & CHR(10))
fString = Substituir(fString, "<br> ", Chr(10))
unHTMLEncode=fString
outro
unHTMLEncode = "$False$"
terminar se
função final
função unhtmllist(conteúdo)
unhtmllist=conteúdo
se conteúdo <> "" então
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
terminar se
função final
função unhtmllists(conteúdo)
unhtmllists=conteúdo
se conteúdo <> "" então
unhtmllists=replace(unhtmllistas,"""","")
unhtmllistas=replace(unhtmllistas,"'","")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
terminar se
função final
função listas html(conteúdo)
htmllistas=conteúdo
se conteúdo <> "" então
htmllistas=replace(htmllistas,"''","""")
htmllistas=replace(htmllistas,"","'")
htmllistas=replace(htmllistas,"<br>",chr(13)&chr(10))
terminar se
função final
função uhtmllists(conteúdo)
uhtmllistas=conteúdo
se conteúdo <> "" então
uhtlists=substituir(uhtlists,"""","''")
uhtlists=replace(uhtlists,"'","";")
uhtlists=substituir(uhtlists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
terminar se
função final
'================================================ =
'Processo: Dormir
'Função: O programa para aqui por alguns segundos
'Parâmetros: iSeconds Número de segundos para pausar
'================================================ =
Sub-suspensão (iSegundos)
response.Write "<font color=blue>Iniciar pausa por "&iSeconds&" segundos</font><br>"
Dim t:t=Temporizador()
Enquanto(Temporizador()<t+iSegundos)
'Não faça nada
Wend
resposta.Escreva "<font color=blue>Pausa"&iSeconds&"fim de segundos</font><br>"
Finalizar sub
'================================================ = =
'Nome da função: MyArray
'Função: extrair tags para separar
'Parâmetro: ConStr ------ Extrai os caracteres originais do endereço
'================================================ = =
Função MeuArray(ByvalConStr)
Definir objRegExp = Novo Regexp
objRegExp.IgnoreCase = Verdadeiro
objRegExp.Global = Verdadeiro
objRegExp.Pattern = "({).+?())"
Definir correspondências =objRegExp.Execute(ConStr)
Para cada partida nas partidas
TempStr=TempStr & "" & Match.Value
Próximo
Definir correspondências = nada
TempStr=Direita(TempStr,Len(TempStr)-1)
objRegExp.Pattern="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern="}"
TempStr=objRegExp.Replace(TempStr,"")
Definir objRegExp = nada
Definir correspondências = nada
TempStr=Substituir(TempStr,"$","")
Se TempStr="" então
MyArray="Nada para extrair no código"
Outro
MeuArray=TempStr
Terminar se
Função final
'================================================ = =
'Nome da função: aleatório
'Função: Gera um número aleatório de 6 dígitos
'================================================ = =
Função aleatória
randomizar
aleatório=Int((900000*rnd)+100000)
Função final
%>