<%
text=getHTTPPage("https://restapi.amap.com/v3/ip?key=0113a13c88697dcea6a445584d535837&ip="&request.ServerVariables("REMOTE_ADDR") ) 
text=tihuan(text)
province=jiequ(text,"province",",")
city=jiequ(text,"city",",")
Response.Cookies("pro")=province
Response.Cookies("city")=city
Response.Cookies("ip")=request.ServerVariables("REMOTE_ADDR")
Response.Cookies("tishi")="有朋自"&replace(province, "省", "")&"来，不亦乐乎！"
Response.Cookies("tishi").Expires=Date+360
Response.Cookies("ip").Expires=Date+360
Response.Cookies("city").Expires=Date+360
Response.Cookies("pro").Expires=Date+360

Function jiema(ByVal urlcode) 
Dim start,final,length,char,i,butf8,pass 
Dim leftstr,rightstr,finalstr 
Dim b0,b1,bx,blength,position,u,utf8 
On Error Resume Next 

b0 = Array(192,224,240,248,252,254) 
urlcode = Replace(urlcode,"+"," ") 
pass = 0 
utf8 = -1 

length = Len(urlcode) : start = InStr(urlcode,"%") : final = InStrRev(urlcode,"%") 
If start = 0 Or length < 3 Then jiema = urlcode : Exit Function 
leftstr = Left(urlcode,start - 1) : rightstr = Right(urlcode,length - 2 - final) 

For i = start To final 
char = Mid(urlcode,i,1) 
If char = "%" Then 
bx = URLDecode_Hex(Mid(urlcode,i + 1,2)) 
If bx > 31 And bx < 128 Then 
i = i + 2 
finalstr = finalstr & ChrW(bx) 
ElseIf bx > 127 Then 
i = i + 2 
If utf8 < 0 Then 
butf8 = 1 : blength = -1 : b1 = bx 
For position = 4 To 0 Step -1 
If b1 >= b0(position) And b1 < b0(position + 1) Then 
blength = position 
Exit For 
End If 
Next 
If blength > -1 Then 
For position = 0 To blength 
b1 = URLDecode_Hex(Mid(urlcode,i + position * 3 + 2,2)) 
If b1 < 128 Or b1 > 191 Then butf8 = 0 : Exit For 
Next 
Else 
butf8 = 0 
End If 
If butf8 = 1 And blength = 0 Then butf8 = -2 
If butf8 > -1 And utf8 = -2 Then i = start - 1 : finalstr = "" : pass = 1 
utf8 = butf8 
End If 
If pass = 0 Then 
If utf8 = 1 Then 
b1 = bx : u = 0 : blength = -1 
For position = 4 To 0 Step -1 
If b1 >= b0(position) And b1 < b0(position + 1) Then 
blength = position 
b1 = (b1 xOr b0(position)) * 64 ^ (position + 1) 
Exit For 
End If 
Next 
If blength > -1 Then 
For position = 0 To blength 
bx = URLDecode_Hex(Mid(urlcode,i + 2,2)) : i = i + 3 
If bx < 128 Or bx > 191 Then u = 0 : Exit For 
u = u + (bx And 63) * 64 ^ (blength - position) 
Next 
If u > 0 Then finalstr = finalstr & ChrW(b1 + u) 
End If 
Else 
b1 = bx * &h100 : u = 0 
bx = URLDecode_Hex(Mid(urlcode,i + 2,2)) 
If bx > 0 Then 
u = b1 + bx 
i = i + 3 
Else 
If Left(urlcode,1) = "%" Then 
u = b1 + Asc(Mid(urlcode,i + 3,1)) 
i = i + 2 
Else 
u = b1 + Asc(Mid(urlcode,i + 1,1)) 
i = i + 1 
End If 
End If 
finalstr = finalstr & Chr(u) 
End If 
Else 
pass = 0 
End If 
End If 
Else 
finalstr = finalstr & char 
End If 
Next 
jiema = leftstr & finalstr & rightstr 
End Function 

Function URLDecode_Hex(ByVal h) 
On Error Resume Next 
h = "&h" & Trim(h) : URLDecode_Hex = -1 
If Len(h) <> 4 Then Exit Function 
If isNumeric(h) Then URLDecode_Hex = cInt(h) 
End Function

Private Function bianma(szInput)
    Dim wch, uch, szRet
    Dim x
    Dim nAsc, nAsc2, nAsc3
    If szInput = "" Then
        bianma= szInput
        Exit Function
    End If
    For x = 1 To Len(szInput)
        wch = Mid(szInput, x, 1)
        nAsc = AscW(wch)
        If nAsc < 0 Then nAsc = nAsc + 65536
        If wch = "+" then
            szRet = szRet & "%2B"
        ElseIf wch = "%" then
            szRet = szRet & "%25"
        ElseIf (nAsc And &HFF80) = 0 Then
            szRet = szRet & wch
        Else
            If (nAsc And &HF000) = 0 Then
                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            Else
                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
    bianma = szRet
End Function

function tihuan(str)
    str = Replace(str, CHR(34), "")
    str = replace(str, ":", "")
    str = replace(str, "：", "")
tihuan=str
end function


Function jiequ(HTML,Start,Last) 
If InStr(HTML,Start)>0 and Start<>"" Then
jiequ_html=right(HTML,len(HTML)-InStr(HTML,Start)-len(Start)+1)
else
jiequ_html=HTML
end if
If InStr(jiequ_html,Last)>0 and Last<>"" Then
jiequ_html=left(jiequ_html,InStr(jiequ_html,Last)-1)
end if
jiequ=jiequ_html
End Function 


Function getHTTPPage(url) 
    On Error Resume Next
    dim http 
    set http=Server.createobject("Microsoft.XMLHTTP") 
    Http.open "GET",url,false 
    Http.send() 
    if Http.readystate<>4 then
        exit function 
    end if 
    getHTTPPage=bytesToBSTR(Http.responseBody,"UTF-8")
    set http=nothing
    If Err.number<>0 then 
       ' Response.Write "<p align='center'><font color='red'><b>服务器获取文件内容出错</b></font></p>" 
        Err.Clear
    End If  
End Function

Function BytesToBstr(body,Cset)
    dim objstream
    set objstream = Server.CreateObject("adodb.stream")
    objstream.Type = 1
    objstream.Mode =3
    objstream.Open
    objstream.Write body
    objstream.Position = 0
    objstream.Type = 2
    objstream.Charset = Cset
    BytesToBstr = objstream.ReadText 
    objstream.Close
    set objstream = nothing
End Function
%>
