<%
Select Case Request("action")
Case "send"
Call RePinYin()
Case "card"
Call GetCard()
Case "cardarea"
Call GetCardCara()
Case else
Call Showmsg()
End Select
Sub GetCardCara()
Dim AreaArr1,AreaArr2,AreaArr3,Area1,Area2,Area3
Dim CiS,LastCode,perIDNew,perIDSrc,ReStr,ajax,i,CiY,TempStr
perIDSrc = Trim(Request("card"))
IF len(perIDSrc) <> 15 and len(perIDSrc) <> 18 then
ReStr = "身份证号码必须为15位或18位数字$$$1$$$1$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
Exit Sub
End If
TempStr = perIDSrc
For i = 1 to 10
TempStr = Replace(TempStr,(i-1) & "","")
Next
TempStr = Replace(TempStr,"X","")
TempStr = Replace(TempStr,"x","")
If TempStr<>"" then
ReStr = "身份证号码必须为15位或18位数字$$$1$$$1$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
Exit Sub
End If
ReStr = ""
If Len(perIDSrc) = 15 Then
If Right(perIDSrc,1) Mod 2 = 0 then
ReStr = ReStr & "女" & "$$$"' & Area3 & "$$$1"
Else
ReStr = ReStr & "男" & "$$$"
End If
ReStr = ReStr & "19" & Mid(perIDSrc,7,2) & "年" & Mid(perIDSrc,9,2) & "月" & Mid(perIDSrc,11,2) & "日" & "$$$"
Else
If Mid(perIDSrc,17,1) Mod 2 = 0 then
ReStr = ReStr & "女" & "$$$"
Else
ReStr = ReStr & "男" & "$$$"
End If
ReStr = ReStr & Mid(perIDSrc,7,4) & "年" & Mid(perIDSrc,11,2) & "月" & Mid(perIDSrc,13,2) & "日" & "$$$"
End If
AreaArr1 = Split("北京市|110000,天津市|120000,河北省|130000,山西省|140000,内蒙古自治区|150000,辽宁省|210000,吉林省|220000,黑龙江省|230000,上海市|310000,江苏省|320000,浙江省|330000,安徽省|340000,福建省|350000,江西省|360000,山东省|370000,河南省|410000,湖北省|420000,湖南省|430000,广东省|440000,广西壮族自治区|450000,海南省|460000,重庆市|500000,四川省|510000,贵州省|520000,云南省|530000,西藏自治区|540000,陕西省|610000,甘肃省|620000,青海省|630000,宁夏回族自治区|640000,新疆维吾尔自治区|650000,台湾省(886)|710000,香港特别行政区(852)|810000,澳门特别行政区(853)|820000",",")
TempStr = Left(perIDSrc,3)
for i=0 to UBOUND(AreaArr1)
If Instr(AreaArr1(i),"|" & TempStr)>0 then
Area1 = Left(AreaArr1(i),Len(AreaArr1(i))-7)
Exit For
End If
Next
Set AreaArr1 = Nothing
Select Case Left(perIDSrc,2)
Case "11"
AreaArr2 = Split("市辖区|110100,北京县|110200",",")
Select Case Mid(perIDSrc,3,2)
Case "01"
AreaArr3 = Split("东城区|110101,西城区|110102,崇文区|110103,宣武区|110104,朝阳区|110105,丰台区|110106,石景山区|110107,海淀区|110108,门头沟区|110109,房山区|110111,通州区|110112,顺义区|110113,昌平区|110114,大兴区|110115,平谷区|110117,怀柔区|110116",",")
Case "02"
AreaArr3 = Split("昌平县|110221,大兴县|110224,平谷县|110226,怀柔县|110227,密云县|110228,延庆县|110229",",")
End Select
……
……
中间的省略了，自己下附件看吧。
……
……
End Select
TempStr = Left(perIDSrc,4)
if not IsArray(AreaArr2) then AreaArr2 = Split(",",",")
for i=0 to UBOUND(AreaArr2)
If Instr(AreaArr2(i),"|" & TempStr)>0 then
Area2 = Left(AreaArr2(i),Len(AreaArr2(i))-7)
Exit For
End If
Next
Set AreaArr2 = Nothing
if not IsArray(AreaArr3) then AreaArr3 = Split(",",",")
TempStr = Left(perIDSrc,6)
for i=0 to UBOUND(AreaArr3)
If Instr(AreaArr3(i),"|" & TempStr)>0 then
Area3 = Left(AreaArr3(i),Len(AreaArr3(i))-7)
Exit For
End If
Next
Set AreaArr3 = Nothing
ReStr = ReStr & Area1 & Area2 & Area3 & "$$$"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
End Sub
Sub GetCard()
Dim CiS,LastCode,perIDNew,perIDSrc,ReStr,ajax,i,CiY,TempStr
perIDSrc = Trim(Request("card"))
IF len(perIDSrc) <> 15 then
ReStr = "原身份证号码必须为15位数字$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
Exit Sub
End If
TempStr = perIDSrc
For i = 1 to 10
TempStr = Replace(TempStr,(i-1) & "","")
Next
If TempStr<>"" then
ReStr = "原身份证号码必须为15位数字$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
Exit Sub
End If
IF len(perIDSrc) <> 15 then
ReStr = "原身份证号码必须为15位$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
Exit Sub
End If
Dim CiW
CiS = 0
'//加权因子常数
CiW=Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2",",")
'//校验码常数
LastCode="10X98765432"
'//新身份证号
perIDNew=Left(perIDSrc,6)
'//填在第6位及第7位上填上‘1’，‘9’两个数字
perIDNew = perIDNew & "19"
perIDNew = perIDNew & mid(perIDSrc,7,10)
'//进行加权求和
for i=0 to UBOUND(CiW)
CiS = CiS + Cint(mid(perIDNew,i+1,1)) * Cint(CiW(i))
Next
'//取模运算，得到模值
CiY = CiS mod 11
'//从LastCode中取得以模为索引号的值，加到身份证的最后一位，即为新身份证号。
perIDNew = perIDNew & Mid(LastCode,CiY+1,1)
ReStr = perIDNew & "$$$1"
set ajax=new AjaxXml
ajax.re(Split(ReStr,"$$$"))
End Sub
Sub Showmsg()
set ajax=new AjaxXml
Dim ReStr
ReStr = "1$$$1"
ajax.re(Split(ReStr,"$$$"))
End Sub
Class AjaxXml
Private m_contentType,m_encoding,m_xml
Private Sub Class_Initialize()
m_contentType = "text/xml"
m_encoding = "gb2312"
m_xml=true
End sub
Public sub re(result)
Response.contentType = m_contentType
Response.Expires=0
Response.Clear
Response.Write serialize(result)
End Sub
Private function serialize(result)
Dim restr,i
if m_xml then
restr = "<?xml version=""1.0"" encoding="""&m_encoding&"""?>"
restr = restr+"<Response>"
if IsArray(result) then
For i=0 to UBound(result)
restr = restr + "<item><![CDATA["&result(i)&"]]></item>"
next
else
restr = restr + result
end If
restr = restr + "</Response>"
else
restr = result
end if
serialize = restr
end function
End Class
%>
共有 0 条评论