Dim
HttpID,AppName,CNZZ_User,CNZZ_Password
HttpID = 0
AppName =
"app_cnzz.com_demo"
CNZZ_User =
"kefu@myw3.cn"
CNZZ_Password =
"CNZZTEST"
Function
OpenHttp(byval url,byval PostData,byref strlocation)
dim xmlhttp,xmlget,bgpos,endpos,sendtype
HttpID = HttpID + 1
if HttpID > 10 then
response.write
"1,连接次数过多"
response.end
end if
strlocation =
""
sendtype =
"SENDTYPE=GET"
Set
xmlhttp = Server.CreateObject(
"WinHttp.WinHttpRequest.5.1"
)
xmlhttp.
Option
(6)=0
With
xmlhttp
.setTimeouts 200000,200000,200000,200000
if left(PostData,len(sendtype)) = sendtype then
url = url &
"?"
& replace(PostData,sendtype,
""
)
PostData =
""
.Open
"GET"
, url ,
False
else
.Open
"POST"
, url,
False
end if
.setRequestHeader
"CONTENT-TYPE"
,
"application/x-www-form-urlencoded"
.setRequestHeader
"Content-Length"
,Len(PostData)
If
Application(AppName &
"APIOPcookie"
)<>
""
Then
.setRequestHeader
"COOKIE"
, Application(AppName &
"APIOPcookie"
)
.Send PostData
If
InStr(LCase(.GetAllResponseHeaders),
"location:"
)
Then
strlocation = .GetResponseHeader(
"location"
)
end if
If
InStr(.GetAllResponseHeaders,
"Set-Cookie"
)
Then
If
InStr(.getResponseHeader(
"Set-Cookie"
),
"PHPSESSID"
) or InStr(.getResponseHeader(
"Set-Cookie"
),
"SPSESSION"
) then
Application(AppName &
"APIOPcookie"
) = .getResponseHeader(
"Set-Cookie"
)
Application(AppName &
"APIOPcookie"
) = left(Application(AppName &
"APIOPcookie"
),instr(1,Application(AppName &
"APIOPcookie"
),
";"
)-1)
End
if
End
If
xmlget = bin2str(.responseBody)
End
With
set xmlhttp = nothing
OpenHttp = xmlget
End
Function
Function
bin2str(byval binstr)
Const
adTypeBinary = 1
Const
adTypeText = 2
Dim
BytesStream,StringReturn
Set
BytesStream = Server.CreateObject(
"ADODB.Stream"
)
With
BytesStream
.Type = adTypeText
.Open
.WriteText binstr
.Position = 0
.Charset =
"GB2312"
.Position = 2
StringReturn = .ReadText
.close
End
With
Set
BytesStream =
Nothing
bin2str = StringReturn
End
Function
function OpenRegExp(byref re)
if not isobject(re) then
set re = new RegExp
re.ignorecase = true
re.global = true
end if
end function
function OnlyTd(byval Html)
Html = replace(Html,vbCrlf,
""
)
Html = replace(Html,
"<br />"
,
""
)
Html = replace(Html,
"<br>"
,
""
)
Html = replace(Html,
"<br/>"
,
""
)
Html = replace(Html,
"</font>"
,
""
)
Html = replace(Html,
" "
,
""
)
call OpenRegExp(re)
Html = re.replace(Html,
""
)
re.pattern =
"<font([^<]*)>"
Html = re.replace(Html,
""
)
OnlyTd = Html
end function
function NotLink(byval Html)
call OpenRegExp(re)
Html = replace(Html,
"</a>"
,
""
)
re.pattern =
"<a([^<]*)>"
Html = re.replace(Html,
""
)
NotLink = Html
end function
function notImage(byval Html)
call OpenRegExp(re)
re.pattern =
"<img([^<]*)>"
Html = re.replace(Html,
""
)
notImage = Html
end function
function midtrim(byval s)
s = trim(s)
s = replace(s,
" "
,
""
)
for k = 0 to 50
s = replace(s,
" "
,
" "
)
next
midtrim = s
end function
Function
Connect(byval act,byval str)
dim html
if instr(html,
"已超时,请重新登录"
)>0 then
if strlocation <>
"/v1/main.php?s=site_list"
then
response.write
"//账号认证失败"
end if
Connect = Connect(act,str)
else
Connect = html
end if
End
Function
Sub
getData()
dim id,html
id = request(
"id"
)
if trim(id) =
""
or not isnumeric(id) then
response.write
"//非法请求"
else
id = cLng(id)
html = Connect(
"v1/data/site_list_data"
,
"SENDTYPE=GETsiteid="
& id)
html =
"var data_arr = "
& html &
";"
& _
"var data_obj = document.getElementById('"
& id &
"_ty').getElementsByTagName('td');"
& _
"data_obj[5].colSpan = 1;"
& _
"var data_cel = data_obj[5].parentNode;"
& _
"data_cel.insertCell();"
& _
"data_cel.insertCell();"
& _
"var outstr = '<table width="
"100%"
">';"
& _
"data_obj[1].innerHTML = data_arr[0][0];"
& _
"data_obj[2].innerHTML = data_arr[0][1];"
& _
"data_obj[3].innerHTML = data_arr[0][2];"
& _
"data_obj[5].innerHTML = data_arr[1][0];"
& _
"data_obj[6].innerHTML = data_arr[1][1];"
& _
"data_obj[7].innerHTML = data_arr[1][2];"
& _
""
response.write html
end if
End
Sub
Sub
Main()
dim html
html = Connect(
"v1/main"
,
"SENDTYPE=GETs=site_list"
)
html = onlyTd(html)
html = notlink(html)
html = notImage(html)
Call
OpenRegExp(re)
html = replace(html,
"获取代码 | 设置 | 清零 | 删除"
,
"-"
)
html = replace(html,
"cellspacing="
"0"
" cellpadding="
"0"
""
,
"cellspacing="
"1"
" cellpadding="
"1"
""
)
re.pattern =
"<span style="
"float:right;padding-top:5px; padding-left:8px;"
"></span></div> </div>(.*)<tr> <td height="
"40"
" colspan="
"5"
" style="
"text-align:center;"
">如希望继续添加站点,请点击此处"
set p = re.execute(html)
if p.count > 0 then
MainUI p(0).submatches(0)
else
end if
End
Sub
Sub
MainUI(byval body)
dim html
body = midtrim(body)
html =
"<html>"
& _
"<head><meta http-equiv="
"Content-Type"
" content="
"text/html;charset=gb2312"
">"
& _
"<title>WinHttpRequest DEMO by Miaoqiyuan.cn - 实时获取CNZZ统计信息</title>"
& _
"<script type="
"text/javascript"
">"
& _
"function site_data(id){var s = document.createElement('script');s.src = '?act=data&id=' + id;document.getElementsByTagName('head')[0].appendChild(s);}"
& _
"</script>"
& _
"<style type="
"text/css"
">"
& _
".list_box{width:900px;background:#666;};"
& _
".list_box td,.list_box th{background:#FFF;line-height:25px;text-align:center;};"
& _
".tr-bg4 td,.tr-bg4 th{background:#666;line-height:25px;};"
& _
"</style>"
& _
"</head>"
& _
"<body><center><h1>WinHttpRequest DEMO by Miaoqiyuan.cn</h1><h2>实时获取CNZZ统计信息</h2><hr />"
& _
body & _
"</table><hr />Copyright: miaoqiyuan.cn 2011-"
& year(now) &
""
& _
"</center></body></html>"
response.write html
End
Sub
select case request(
"act"
)
case
"data"
Call
getData()
case else
Call
Main()
end select