WinHttpRequest使用方法，WinHttpRequest演示实例
最近经常需要开发API，Microsoft.XMLHttp、MSXML2.XMLHTTP 等组件不能满足我的要求(主要是不能自定义header等信息)，通过查资料发现了WinHttp.WinHttpRequest.5.1，但是关于winhttprequest的资料太少了。通过这几天摸索，勉强了解了WinHttpRequest使用方法。
WinHttp.WinHttpRequest是一个非常实用的一个组件。作为站长，就会经常关注自己网站的流浪，今天以 免登陆获得cnzz统计信息 和 免登陆获得51.la统计信息 为例，一起了解下WinHttpRequest的使用方法。CNZZ会员系统没有使用验证码，而51.la使用了验证码，针对两种不同的系统，我们分两种方法讨论。
- 实时获取CNZZ统计信息 ASP版
- WinHttp.WinHttpRequest采集无验证码会员系统实例
- 实时获取51.la统计信息 ASP版
- WinHttp.WinHttpRequest采集有验证码会员系统实例
实时获取CNZZ统计信息 ASP版
'=====================================================================
'= WinHttpRequest演示实例 - 实时获取CNZZ统计信息 =
'= Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd. =
'= 请尊重作者劳动成果，转载请保留代码的完整性 =
'=====================================================================
'= 作者：苗启源(博客:http://www.miaoqiyuan.cn) =
'= 讨论：http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo
'= 最新：http://www.miaoqiyuan.cn/products/winhttprequest_demo.rar
'=====================================================================
'= 返回首页站点列表： winhttprequest_demo.asp =
'= 返回某站统计数据： winhttprequest_demo.asp?act=data&id=[站点ID] =
'=====================================================================
'= 文件名：winhttprequest_demo.asp =
'= 功 能：免登陆查看CNZZ 网站流量统计信息 =
'=====================================================================
Dim HttpID,AppName,CNZZ_User,CNZZ_Password
HttpID = 0
AppName = "app_cnzz.com_demo" '应用程序名前缀，防止感染其他程序Application变量
CNZZ_User = "kefu@myw3.cn" 'CNZZ账号
CNZZ_Password = "CNZZTEST" 'CNZZ密码
'函数名：OpenHttp
'功 能：创建Http请求，并返回服务器处理结果
'参 数：url 请求地址
' PostData 请求数据包，如果是Get请求，请以SENDTYPE=GET开头
' &strlocation 如果是服务器重定向网址，则返回重定向的地址
'特 点：自动保存/共享cookies，多次请求能保存登录状态
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)
.setRequestHeader "Referer","http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo"
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
'函数名：bin2str
'功 能：将2进制值转换为GB2312编码的字符串
'参 数：binstr 要转换的字符
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
'函数名：OpenRegExp
'功 能：创建正则对象，如果已经创建，则不重复创建
'参 数：&re 要创建的正则对象变量名称
function OpenRegExp(byref re)
if not isobject(re) then
set re = new RegExp
re.ignorecase = true
re.global = true
end if
end function
'函数名：OnlyTd
'功 能：去掉字体样式、换行符、空格
'参 数：html 要处理的Html代码
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
'函数名：NotLink
'功 能：去掉所有链接
'参 数：html 要处理的Html代码
function NotLink(byval Html)
call OpenRegExp(re)
Html = replace(Html,"</a>","")
re.pattern = "<a([^<]*)>"
Html = re.replace(Html,"")
NotLink = Html
end function
'函数名：notImage
'功 能：去掉所有图片标签
'参 数：html 要处理的Html代码
function notImage(byval Html)
call OpenRegExp(re)
re.pattern = "<img([^<]*)>"
Html = re.replace(Html,"")
notImage = Html
end function
'函数名：midtrim
'功 能：去掉所有多余的空格
'参 数：html 要处理的Html代码
function midtrim(byval s)
s = trim(s)
s = replace(s," ","")
for k = 0 to 50
s = replace(s," "," ")
next
midtrim = s
end function
'函数名：Connect
'功 能：连接CNZZ并返回处理结果，如果没有登录，自动重新登录
'参 数：act 操作名称，主要简化代码量("http://new.cnzz.com/[ACT].php")
' str 请求的数据
Function Connect(byval act,byval str)
dim html
html = OpenHttp("http://new.cnzz.com/" & act & ".php",str,strlocation)
'如果未登录状态
if instr(html,"已超时，请重新登录")>0 then
'重新登陆
login = OpenHttp("http://new.cnzz.com/user/login.php","username=" & CNZZ_User & "&password=" & CNZZ_Password & "&list=1&remuser=1",strlocation)
if strlocation <> "/v1/main.php?s=site_list" then
response.write "//账号认证失败"
end if
Connect = Connect(act,str)
else
Connect = html
end if
End Function
'方法名：getData
'功 能：从CNZZ返回某站点数据
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
'方法名：Main
'功 能：从CNZZ返回站点列表
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
response.write "对不起，CNZZ改版了。请访问：http://www.miaoqiyuan.cn/p/WinHttp-WinHttpRequest-5-1_DEMO 获取最新版本"
end if
End Sub
'方法名：MainUI
'功 能：友好的显示处理结果
'参 数：body 输出正文内容
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
实时获取51.la统计信息 ASP版
'=======================================================================
'= WinHttpRequest演示实例 - 实时获取51.la统计信息 =
'= Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd. =
'= 请尊重作者劳动成果，转载请保留代码的完整性 =
'=======================================================================
'= 作者：苗启源(博客:http://www.miaoqiyuan.cn) =
'= 讨论：http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo
'= 最新：http://www.miaoqiyuan.cn/products/winhttprequest_51lademo.rar
'=======================================================================
'= 返回首页站点列表： winhttprequest_demo_51la.asp =
'= 读取并输出验证码： winhttprequest_demo_51la.asp?act=getcode =
'= 显示数据验证码框： winhttprequest_demo_51la.asp?act=login =
'= 验证验证码并登陆： winhttprequest_demo_51la.asp?act=dologin =
'=======================================================================
'= 文件名：winhttprequest_demo_51la.asp =
'= 功 能：免登陆查看51.la 网站流量统计信息 =
'=======================================================================
Dim HttpID,AppName,CNZZ_User,CNZZ_Password
HttpID = 0
AppName = "app_51.la_demo" '应用程序名前缀，防止感染其他程序Application变量
La51_User = "myw3demo" '51.la账号
La51_Password = "la51test" '51.la密码
'函数名：OpenHttp
'功 能：创建Http请求，并返回服务器处理结果
'参 数：url 请求地址
' PostData 请求数据包，如果是Get请求，请以SENDTYPE=GET开头
' &strlocation 如果是服务器重定向网址，则返回重定向的地址
'特 点：自动保存/共享cookies，多次请求能保存登录状态，新增二进制获取
Function OpenHttp(byval url,byval PostData,byref strlocation)
dim xmlhttp,xmlget,bgpos,endpos,sendtype,imgtype,isbinstr
HttpID = HttpID + 1
if HttpID > 10 then
response.write "1,连接次数过多"
response.end
end if
strlocation = ""
'与CNZZ的实例对比，增加了获取验证码的功能
sendtype = "SENDTYPE=GET"
imgtype = "GETTYPE=IMAGE"
isbinstr = false
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 or left(PostData,len(imgtype)) = imgtype then
if left(PostData,len(sendtype)) = sendtype then
url = url & "?" & replace(PostData,sendtype,"")
else
url = url & "?" & replace(PostData,imgtype,"")
isbinstr = true
end if
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)
.setRequestHeader "Referer","http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo"
If Application(AppName & "APIOPcookie")<>"" Then .setRequestHeader "COOKIE", Application(AppName & "APIOPcookie")
.Send PostData
If InStr(LCase(.GetAllResponseHeaders),"location:") Then
strlocation = .GetResponseHeader("location")
end if
'阿江的Cookies比较变态，有3个Set-Cookie，因为这个问题，浪费了好几个小时
If InStr(.GetAllResponseHeaders,"Set-Cookie") Then
Application(AppName & "APIOPcookie") = getAJiangCookies(.GetAllResponseHeaders)
End If
if isbinstr then
xmlget = .responseBody
else
xmlget = bin2str(.responseBody)
end if
End With
set xmlhttp = nothing
OpenHttp = xmlget
End Function
'函数名：bin2str
'功 能：将2进制值转换为GB2312编码的字符串
'参 数：binstr 要转换的字符
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
'函数名：getAJiangCookies
'功 能：从http头中返回多个cookies值
'参 数：strHeader HTTP头
Function getAJiangCookies(byval strHeader)
dim tmp,ltmp,sck
tmp = ""
sck = "Set-Cookie:"
for each ltmp in split(strHeader,vbCrlf)
if left(ltmp,len(sck)) = sck then
if tmp <> "" then tmp = tmp & ";"
ltmp = mid(ltmp,len(sck) + 2)
tmp = tmp & split(ltmp,"; ")(0)
end if
next
tmp = tmp & "; expires=Tue, 23-Sep-2014 16:00:00 GMT; path=/"
getAJiangCookies = tmp
End Function
'函数名：OpenRegExp
'功 能：创建正则对象，如果已经创建，则不重复创建
'参 数：&re 要创建的正则对象变量名称
Function OpenRegExp(byref re)
if not isobject(re) then
set re = new RegExp
re.ignorecase = true
re.global = true
end if
End Function
'函数名：NotLink
'功 能：去掉所有链接
'参 数：html 要处理的Html代码
Function NotLink(byval Html)
call OpenRegExp(re)
Html = replace(Html,"</a>","")
re.pattern = "<a([^<]*)>"
Html = re.replace(Html,"")
NotLink = Html
End Function
'函数名：notImage
'功 能：去掉所有图片标签
'参 数：html 要处理的Html代码
function notImage(byval Html)
call OpenRegExp(re)
re.pattern = "<img([^<]*)>"
Html = re.replace(Html,"")
notImage = Html
end function
'函数名：midtrim
'功 能：去掉所有多余的空格
'参 数：html 要处理的Html代码
Function midtrim(byval s)
s = trim(s)
s = replace(s," ","")
for k = 0 to 50
s = replace(s," "," ")
next
midtrim = s
End Function
'函数名：Connect
'功 能：连接51.la并返回处理结果，如果没有登录，自动重新登录
'参 数：act 操作名称，主要简化代码量("http://www.51.la/[ACT].asp")
' str 请求的数据
Function Connect(byval act,byval str)
dim html
html = OpenHttp("http://www.51.la/" & act & ".asp",str,strlocation)
'如果未登录状态，则进入登录页面
if strlocation = "../login.asp" then
response.redirect "?act=login"
elseif strlocation <> "" then
Connect = strlocation
else
Connect = html
end if
End Function
'方法名：getCode
'功 能：获取验证码
Sub getCode()
dim html
Response.Expires = -9999
Response.AddHeader "Pragma","no-cache"
Response.AddHeader "cache-ctrol","no-cache"
Response.ContentType = "Image/BMP"
response.binarywrite Connect("user/vcode","GETTYPE=IMAGE")
End Sub
'方法名：Main
'功 能：从51.la返回站点列表
Sub Main()
dim html,pe,pa,pm,re,ra,rm
html = Connect("user/index","SENDTYPE=GETall=yes")
html = notImage(html)
html = notLink(html)
Call OpenRegExp(re)
Call OpenRegExp(ra)
Call OpenRegExp(rm)
re.pattern = "[\S\s]*点击“查看统计报表”可查看实时数据。"
ra.pattern = "\( 合计当前显示的[\S\s]*"
rm.pattern = "<div class=""sitelist_o"">[^<]*</div>"
set pe = re.execute(html)
set pa = ra.execute(html)
set pm = rm.execute(html)
if pe.count = 0 or pa.count = 0 or pm.count = 0 then
response.write "对不起，51.la改版了。请访问：http://www.miaoqiyuan.cn/p/WinHttp-WinHttpRequest-5-1_DEMO 获取最新版本"
else
html = re.replace(html,"")
html = ra.replace(html,"")
html = rm.replace(html,"")
html = "<div>" & html & "</div>"
Call MainUI(html)
end if
End Sub
'方法名：Login
'功 能：获取登录界面
Sub Login()
dim html
html = "<form action=""?act=dologin"" method=""POST"">" & _
"第一次访问的时候，需要输入验证码：" & _
"<input name=""vcode"" size=""4"" />" & _
" <img src=""?act=getcode&timer=" & timer() & """ /> " & _
"<input type=""submit"" value=""提交""/>" & _
"</form>"
Call MainUI(html)
End Sub
'方法名：doLogin
'功 能：登录51.la
Sub doLogin()
dim html,vcode,sendStr
vcode = request("vcode")
sendStr = "uname=" & La51_User & _
"&upass=" & La51_Password & _
"&vcode=" & vcode & _
"&remb=yes"
html = Connect("login",sendStr)
if html = "user/" then
response.redirect "?act=list"
elseif instr(html,"验证码不正确") then
Call MainUI("<a href=""?act=login"">验证码不正确，请重新登录</a>")
else
Call MainUI("<a href=""?act=login"">账号或密码错误，请修改配置并重新登录</a>")
end if
End Sub
'方法名：MainUI
'功 能：友好的显示处理结果
'参 数：body 输出正文内容
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 - 实时获取51.la统计信息</title>" & _
"<style type=""text/css"">" & _
".sitelist_n{height:35px;width:620px;background:#CCC;color:#000;line-height:35px;text-align:left;text-indent:10px;font-weight:800;}" & _
".sitelist_s{height:35px;width:620px;color:#666;line-height:35px;font-size:13px;text-align:left;text-indent:20px;}" & _
"</style>" & _
"</head>" & _
"<body><center><h1>WinHttpRequest DEMO by Miaoqiyuan.cn</h1><h2>实时获取51.la统计信息</h2><hr />" & _
body & _
"<hr />Copyright: miaoqiyuan.cn 2011-" & year(now) & "" & _
"</center></body></html>"
response.write html
End Sub
'入口
select case request("act")
case "getcode"
Call getCode()
case "login"
Call Login()
case "dologin"
Call doLogin()
case else
Call Main()
end select
