<%
dim html,ttlsturl,Lsttop,Lstend,hahyay,ppp,i,tt
Lsttop = "地：</td><td class=""tdc2"">"
Lstend = "<br/>"
ttlsturl = "http://qq.ip138.com/idsearch/index.asp?action=idcard&userid=id"
Html = GetURL(ttlsturl)
LstNews = GetKeylst(Html,Lsttop,Lstend)
hahyay = split(LstNews," ")
ppp = ubound(hahyay)
tt = 0
for i =0 to ppp
response.Write(hahyay(tt))
tt = tt + 1
next
Function GetURL(url)
Dim Retri
Set Retri = CreateObject("Microsoft.XMLHTTP")
With Retri
.Open "GET", url, False
.Send
GetURL = bytes2bstr(.responsebody)
'对取得信息进行验证，如果信息长度小于100则说明截取失败
if len(.responsebody)<100 then
response.write "获取远程文件 <a href="&url&" target=_blank>"&url&"</a> 失败。"
response.end
end if
End With
Set Retri = Nothing
End Function
'==================================================
'过程名：bytes2bstr
'作 用：二进制代码进行转换
'参 数：vin
'==================================================
function bytes2bstr(vin)
Dim strreturn,thischarcode,nextcharcode
strreturn = ""
for i = 1 to lenb(vin)
thischarcode = ascb(midb(vin,i,1))
if thischarcode < &h80 then
strreturn = strreturn & chr(thischarcode)
else
nextcharcode = ascb(midb(vin,i+1,1))
strreturn = strreturn & chr(clng(thischarcode) * &h100 + cint(nextcharcode))
i = i + 1
end if
next
bytes2bstr = strreturn
end Function
'==================================================
'过程名：GetKeylst
'作 用：截取代码
'参 数：HTML,Start,Last
'==================================================
Function GetKeylst(HTMLs,Starts,Lasts)
Dim filearrays,filearray2s
filearrays=split(HTMLs,Starts)
'redim preserve filearrays(1)
'If IsArray(filearrays) then
filearray2s=split(filearrays(1),Lasts)
'Else
' Response.Write ("<script language=javascript>setTimeout('3000');location='?step=step5&pages="&pages&"&XMID="&XMID&"'</script>")
'End If
'redim preserve filearray2s
'If IsArray(filearray2s) Then
GetKeylst=filearray2s(0)
'Else
' Response.Write ("<script language=javascript>setTimeout('3000');location='?step=step5&pages="&pages&"&XMID="&XMID&"'</script>")
'End if
End Function
'==================================================
'过程名：GetKey
'作 用：截取代码
'参 数：HTML,Start,Last
'==================================================
Sub Hint(message)
Response.Write "<script language=JavaScript>alert(""" & message & """);</script>"
End Sub
Function GetKey(HTML,Start,Last)
Dim filearray,filearray2
Dim abc
abc = Trim(request("abc"))
call hint(HTML)
filearray=split(HTML,Start)
'redim preserve filearray(1)
'If IsArray(filearray) then
'response.Write(filearray(1))
filearray2=split(filearray(1),Last)
'Else
' Response.Write ("<script language=javascript>setTimeout('3000');location='?step=step6&pages="&pages&"&abc="&abc&"&XMID="&XMID&"'</script>")
'End if
'If IsArray(filearray2) Then
GetKey=filearray2(0)
'Else
' Response.Write ("<script language=javascript>setTimeout('3000');location='?step=step6&pages="&pages&"&abc="&abc&"&XMID="&XMID&"'</script>")
'End if
End Function
'==================================================
Function RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
Set Matches = objRegExp.Execute(strHTML)
For Each Match in Matches
strHtml=Replace(strHTML,Match.Value,"")
Next
RemoveHTML=strHTML
Set objRegExp = Nothing
set Matches=nothing
End Function
'==================================================
'函数名：GetArray
'作 用：提取链接地址，以$Array$分隔
'参 数：ConStr ------提取地址的原字符
'参 数：StartStr ------开始字符串
'参 数：OverStr ------结束字符串
'参 数：IncluL ------是否包含StartStr
'参 数：IncluR ------是否包含OverStr
'==================================================
Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetArray="$False$"
Exit Function
End If
Dim TempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & "$Array$" & Match.Value
Next
Set Matches=nothing
If TempStr="" Then
GetArray="$False$"
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
If IncluL=False then
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
End if
If IncluR=False then
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
End if
Set objRegExp=nothing
Set Matches=nothing
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
TempStr=Replace(TempStr,"(","")
TempStr=Replace(TempStr,")","")
If TempStr="" then
GetArray="$False$"
Else
GetArray=TempStr
End if
End Function
'==================================================
'函数名：FpHtmlEnCode
'作 用：标题过滤
'参 数：fString ------字符串
'==================================================
Function FpHtmlEnCode(fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString=nohtml(fString)
fString=FilterJS(fString)
fString = Replace(fString," ","")
fString = Replace(fString,"'","")
fString = replace(fString, ">", "")
fString = replace(fString, "<", "")
fString = Replace(fString, CHR(9), " ")'
fString = Replace(fString, CHR(10), "")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(14),"")
fString = Replace(fString, CHR(34), "")
fString = Replace(fString, CHR(32), " ")'space
fString = Replace(fString, CHR(39), "")
fString = Replace(fString, CHR(10) & CHR(10),"")
fString = Replace(fString, CHR(10)&CHR(13), "")
fString=Trim(fString)
FpHtmlEnCode=fString
Else
FpHtmlEnCode="$False$"
End If
End Function
'==================================================
'函数名：body
'作 用：循环采集列表
'参 数：fString ------字符串
'==================================================
function body(wstr,start,over)
Dim Matches,Match
set gaozhen = new regexp '设置配置对象
gaozhen.ignorecase = true '忽略大小写
gaozhen.global = true '设置为全文搜索
gaozhen.pattern = ""&start&".+?"&over&"" '正则表达式
set matches =gaozhen.execute(wstr) '开始执行配置
set gaozhen=nothing
body=""
for each match in matches
body = body & Replace(Replace(match.value,start,"$$$$"),over,"") '循环匹配
next
end function
'==================================================
'函数名：MtoKB
'作 用：M的尺寸变成KB并且为纯数字
'参 数：fString ------字符串
'==================================================
Function MtoKB(fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString=Replace(fString," ","")
fString=Replace(fString,"K","")
fString=Replace(fString,"k","")
fString=Replace(fString,"b","")
fString=Replace(fString,"m","")
fString=Replace(fString,"b","")
fString=Replace(fString,"M","")
fString=Replace(fString,"B","")
fString=Replace(fString,"G","")
'fString=Replace(fString,"MB","")
'MB
fString = int(fString*1024)
MtoKB = fString
End If
End Function
%>
友情提供 直销软件 www.pujigo.cn
