asp采集身份证号返回省市县

<%

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

©著作权归作者所有,转载或内容合作请联系作者
  • 人面猴
    序言：七十年代末，一起剥皮案震惊了整个滨河市，随后出现的几起案子，更是在滨河造成了极大的恐慌，老刑警刘岩，带你破解...
    沈念sama阅读 215,539评论 6赞 497
  • 死咒
    序言：滨河连续发生了三起死亡事件，死亡现场离奇诡异，居然都是意外死亡，警方通过查阅死者的电脑和手机，发现死者居然都...
    沈念sama阅读 91,911评论 3赞 391
  • 救了他两次的神仙让他今天三更去死
    文/潘晓璐 我一进店门，熙熙楼的掌柜王于贵愁眉苦脸地迎上来，“玉大人，你说我怎么就摊上这事。” “怎么了？”我有些...
    开封第一讲书人阅读 161,337评论 0赞 351
  • 道士缉凶录：失踪的卖姜人
    文/不坏的土叔 我叫张陵，是天一观的道长。 经常有香客问我，道长，这世上最难降的妖魔是什么？ 我笑而不...
    开封第一讲书人阅读 57,723评论 1赞 290
  • 港岛之恋（遗憾婚礼）
    正文 为了忘掉前任，我火速办了婚礼，结果婚礼上，老公的妹妹穿的比我还像新娘。我一直安慰自己，他们只是感情好，可当我...
    茶点故事阅读 66,795评论 6赞 388
  • 恶毒庶女顶嫁案：这布局不是一般人想出来的
    文/花漫 我一把揭开白布。 她就那样静静地躺着，像睡着了一般。 火红的嫁衣衬着肌肤如雪。 梳的纹丝不乱的头发上，一...
    开封第一讲书人阅读 50,762评论 1赞 294
  • 城市分裂传说
    那天，我揣着相机与录音，去河边找鬼。 笑死，一个胖子当着我的面吹牛，可吹牛的内容都是我干的。 我是一名探鬼主播，决...
    沈念sama阅读 39,742评论 3赞 416
  • 双鸳鸯连环套：你想象不到人心有多黑
    文/苍兰香墨 我猛地睁开眼，长吁一口气：“原来是场噩梦啊……” “哼！你这毒妇竟也来了？” 一声冷哼从身侧响起，我...
    开封第一讲书人阅读 38,508评论 0赞 271
  • 万荣杀人案实录
    序言：老挝万荣一对情侣失踪，失踪者是张志新（化名）和其女友刘颖，没想到半个月后，有当地人在树林里发现了一具尸体，经...
    沈念sama阅读 44,954评论 1赞 308
  • 护林员之死
    正文 独居荒郊野岭守林人离奇死亡，尸身上长有42处带血的脓包…… 初始之章·张勋 以下内容为张勋视角 年9月15日...
    茶点故事阅读 37,247评论 2赞 331
  • 白月光启示录
    正文 我和宋清朗相恋三年，在试婚纱的时候发现自己被绿了。 大学时的朋友给我发了我未婚夫和他白月光在一起吃饭的照片。...
    茶点故事阅读 39,404评论 1赞 345
  • 活死人
    序言：一个原本活蹦乱跳的男人离奇死亡，死状恐怖，灵堂内的尸体忽然破棺而出，到底是诈尸还是另有隐情，我是刑警宁泽，带...
    沈念sama阅读 35,104评论 5赞 340
  • 日本核电站爆炸内幕
    正文 年R本政府宣布，位于F岛的核电站，受9级特大地震影响，放射性物质发生泄漏。R本人自食恶果不足惜，却给世界环境...
    茶点故事阅读 40,736评论 3赞 324
  • 男人毒药：我在死后第九天来索命
    文/蒙蒙 一、第九天 我趴在偏房一处隐蔽的房顶上张望。 院中可真热闹，春花似锦、人声如沸。这庄子的主人今日做“春日...
    开封第一讲书人阅读 31,352评论 0赞 21
  • 一桩弑父案，背后竟有这般阴谋
    文/苍兰香墨 我抬头看了看天上的太阳。三九已至，却和暖如春，着一层夹袄步出监牢的瞬间，已是汗流浃背。 一阵脚步声响...
    开封第一讲书人阅读 32,557评论 1赞 268
  • 情欲美人皮
    我被黑心中介骗来泰国打工， 没想到刚下飞机就差点儿被人妖公主榨干…… 1. 我叫王不留，地道东北人。 一个月前我还...
    沈念sama阅读 47,371评论 2赞 368
  • 代替公主和亲
    正文 我出身青楼，却偏偏与公主长得像，于是被迫代替她去往敌国和亲。 传闻我的和亲对象是个残疾皇子，可洞房花烛夜当晚...
    茶点故事阅读 44,292评论 2赞 352

推荐阅读更多精彩内容