九乡新闻网诛仙3戒指怎么强化:ServerXmlhttp操作网页例子
来源：百度文库 编辑：九乡新闻网 时间：2024/04/28 02:17:53
以前我都是用的xmlhttp，包括8月份写的吧吧管理器也用到了xmlhttp来获取网页源码，xmlhttp获取网页源码速度很快，然后配合自己写的延时函数，也用的很爽。。
但是缺点也来了，由于它是基于和IE同Cookie的，所以获取网页源码的同时该网站的Cookie、缓存等信息全部保存了下来，这样有个不好的地方，就是每更新一次网页<比如每2秒刷新一次贴吧帖子列表>，都需要我们手动去清除缓存或者Cookie,这样很不方便而且不能实现"多开"的效果<该网站上只能登录一个帐号，登录第二个时会自动覆盖,比如你程序里面登录帐号A，然后打开IE会发现自动就是帐号A了。。那我们想换帐号B的话程序里面的帐号A会被覆盖成帐号B>
于是ServerXmlhttp就诞生了
ServerXmlhttp和xmlhttp相比他不会产生缓存、cookie等信息,针对xmlhttp不能设置异步超时的弱点它出了强大的waitForResponse方法等待异步完成。。针对xmlhttp不能设置代理的弱点它出了强大的setproxy方法来设置代理
自由设置Http头、强大的异步等待、强大的代理设置。。。这些相信操作网页的朋友们都会喜欢上它
下面是具体操作的代码
任务:1.登录论坛http://www.moonsclub.com
2.找个板块发帖
实战:
1.上论坛点登录-Httpwatch截包-分析Post参数<发现需要参数formhash,并且在源码里有>
2.随便找个板块发帖-截包-分析Post参数<发现需要参数formhash和posttime,在源码里同样存在;还有标题前面是[101229]明显是20101229去掉20后形成的;还要注意标题和内容都是UTF8编码的>
代码思路:
1.先GET登录入口获取参数formhash:http://www.moonsclub.com/logging.php?action=login&infloat=yes&handlekey=login&inajax=1&ajaxtarget=fwin_content_login；
2.Post数据到http://www.moonsclub.com/logging.php?action=login&loginsubmit=yes，然后根据返回的源码来判断登录是否成功，登录成功的话就获取服务器返回的Http头来找cookie；
3.根据返回的cookie，设置ServerXmlhttp的cookie然后GET板块地址，获取2个参数formhash和posttime；然后再Post发往http://www.moonsclub.com/post.php?action=newthread&fid=57&extra=&topicsubmit=yes
上代码:
'添加text1、text2、text3，分别是帐、密、发帖的返回值
Dim Login%, MyCookie$ '登录状态和cookie
Private Function XMLHttpRequest(ByVal XmlHttpMode, ByVal XmlHttpURL, ByVal XmlHttpData)
Dim MyXmlhttp
On Error GoTo wrong
Set MyXmlhttp = CreateObject("Msxml2.ServerXMLHTTP.6.0")
With MyXmlhttp
.setTimeouts 5000, 5000, 5000, 5000 '设置超时
If XmlHttpMode = "POST" Then '设置是GET方法还是POST方法,并且设置异步获取
.Open "POST", XmlHttpURL, True
Else
.Open "GET", XmlHttpURL, True
End If
If XmlHttpMode = "POST" Then
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
End If
If Login = 2 Then '登录成功后加上cookie,服务器才认为你是登录用户
.setRequestHeader "Referer", "http://www.moonsclub.com/post.php?action=newthread&fid=30&referer=http%3A//www.moonsclub.com/forumdisplay.php%3Ffid%3D30" '带上来路免得服务器说你非法来路哈哈
.setRequestHeader "Cookie", MyCookie
End If
.send XmlHttpData
.waitForResponse '设置异步等待
If MyXmlhttp.Status = 200 Then '返回的Http头200才是正常的
XMLHttpRequest = .responseText '设置responseText是自动UTF8解码的
If Login = 1 Then
If InStr(.responseText, "欢迎您回来") <> 0 Then '判断是否登录成功
Login = 2
MyCookie = GetCookie(.getAllResponseHeaders)
Else '登录失败
MsgBox "登录失败"
End If
End If
Else
'XMLHttpRequest = "Http错误代码:" & .Status
XMLHttpRequest = ""
End If
End With
Set MyXmlhttp = Nothing
Exit Function
wrong:
'XMLHttpRequest = "错误原因:" & Err.Description & ""
XMLHttpRequest = ""
Set MyXmlhttp = Nothing
End Function
Private Sub Command1_Click() '登录
Dim webcode$, PostDate$
Login = 0
webcode = XMLHttpRequest("GET", "http://www.moonsclub.com/logging.php?action=login&infloat=yes&handlekey=login&inajax=1&ajaxtarget=fwin_content_login", "") '这里先去获取参数formhash
If webcode = "" Then MsgBox "请检查网络连接": Exit Sub
a = InStr(webcode, "formhash"): b = InStr(a, webcode, "="): c = InStr(b + 2, webcode, """")
formhash = Mid(webcode, b + 2, c - b - 2)
Login = 1
PostDate = "formhash=" & formhash & "&loginfield=username&username=" & Text1.Text & "&password=" & Text2.Text & "&questionid=0&answer=&loginsubmit=%E7%99%BB%E5%BD%95"
Call XMLHttpRequest("POST", "http://www.moonsclub.com/logging.php?action=login&loginsubmit=yes", PostDate) '根据参数再提交登录
End Sub
Private Function GetCookie(str$) '处理cookie的函数,getResponseHeader方法只返回一个setcookie的明显不完整
Dim cookie$
a = InStr(str, "Set-Cookie: ") '没发现Set-Cookie直接返回空，说明服务器没返回Set-Cookie
If a = 0 Then
GetCookie = ""
Else
b = InStr(a, str, ";"): c = Mid(str, a + 12, b - a - 11)
cookie = c
Do '循环查找Set-Cookie，并把cookie值都串起来
d = InStr(b, str, "Set-Cookie: ")
If d = 0 Then Exit Do
e = InStr(d, str, ";"): f = Mid(str, d + 12, e - d - 11)
b = e
cookie = cookie & f
Loop
GetCookie = cookie
End If
End Function
Private Sub Post()
Dim webcode$, PostDate$, Title$, Content$
webcode = XMLHttpRequest("GET", "http://www.moonsclub.com/post.php?action=newthread&fid=30&referer=http%3A//www.moonsclub.com/forumdisplay.php%3Ffid%3D30", "") '还是老规矩获取参数
If webcode = "" Then MsgBox "请检查网络连接": Exit Sub
Text1.Text = webcode
a = InStr(webcode, "formhash"): b = InStr(a, webcode, "="): c = InStr(b + 2, webcode, """")
a1 = InStr(webcode, "posttime"): b1 = InStr(a1, webcode, "="): c1 = InStr(b1 + 1, webcode, """")
formhash = Mid(webcode, b + 1, c - b - 1): posttime = Mid(webcode, b1 + 1, c1 - b1 - 1)
Title = "[" & Replace(Year(Now), "20", "") & "]" & Month(Now) & Day(Now) & "这么晚了怎么还有这么多人在线呢" '这里最后的文字就是发帖的标题大家可以改一下我怕封所以瞎扯了个标题发。。
Content = "郁闷了~~" '这里就是帖子的内容
PostDate = "formhash=" & formhash & "&posttime=" & posttime & "&wysiwyg=0&iconid=&subject=" & UTF8EncodeURI(Title) & "&typeid=7&checkbox=0&message=" & UTF8EncodeURI(Content) & "&tags=&addtags=%2B%E5%8F%AF%E7%94%A8%E6%A0%87%E7%AD%BE"
Text3.Text = XMLHttpRequest("POST", "http://www.moonsclub.com/post.php?action=newthread&fid=57&extra=&topicsubmit=yes", PostDate) '这里能查看帖子有没有正常发出
End Sub
Private Sub Command2_Click() '发帖
Call Post
End Sub
Private Function UTF8EncodeURI(ByVal szInput As String) As String
Dim wch As String
Dim uch As String
Dim szRet As String
Dim x As Long
Dim inputLen As Long
Dim nAsc As Long
Dim nAsc2 As Long
Dim nAsc3 As Long
If szInput = "" Then
UTF8Encode = szInput
Exit Function
End If
inputLen = Len(szInput)
For x = 1 To inputLen
'得到每个字符
wch = Mid(szInput, x, 1)
'得到相应的UNICODE编码
nAsc = AscW(wch)
'对于<0的编码 其需要加上65536
If nAsc < 0 Then nAsc = nAsc + 65536
'对于<128位的ASCII的编码则无需更改
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
'真正的第二层编码范围为000080 - 0007FF
'Unicode在范围D800-DFFF中不存在任何字符，基本多文种平面中约定了这个范围用于UTF-16扩展标识辅助平面（两个UTF-16表示一个辅助平面字符）.
'当然，任何编码都是可以被转换到这个范围，但在unicode中他们并不代表任何合法的值。
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
'第三层编码00000800 – 0000FFFF
'首先取其前四位与11100000进行或去处得到UTF-8编码的前8位
'其次取其前10位与111111进行并运算，这样就能得到其前10中最后6位的真正的编码 再与10000000进行或运算来得到UTF-8编码中间的8位
'最后将其与111111进行并运算，这样就能得到其最后6位的真正的编码 再与10000000进行或运算来得到UTF-8编码最后8位编码
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
UTF8EncodeURI = szRet
End Function
有什么不清楚的可以留言
附:
Xmlhttp手册下载地址:http://www.sunshinebean.com/upload/v.asp?id=64
ServerXmlhttp手册下载地址:http://www.sunshinebean.com/upload/v.asp?id=63
本文用到的截包工具HttpWatch下载地址:http://download.csdn.net/source/2688506
但是缺点也来了，由于它是基于和IE同Cookie的，所以获取网页源码的同时该网站的Cookie、缓存等信息全部保存了下来，这样有个不好的地方，就是每更新一次网页<比如每2秒刷新一次贴吧帖子列表>，都需要我们手动去清除缓存或者Cookie,这样很不方便而且不能实现"多开"的效果<该网站上只能登录一个帐号，登录第二个时会自动覆盖,比如你程序里面登录帐号A，然后打开IE会发现自动就是帐号A了。。那我们想换帐号B的话程序里面的帐号A会被覆盖成帐号B>
于是ServerXmlhttp就诞生了
ServerXmlhttp和xmlhttp相比他不会产生缓存、cookie等信息,针对xmlhttp不能设置异步超时的弱点它出了强大的waitForResponse方法等待异步完成。。针对xmlhttp不能设置代理的弱点它出了强大的setproxy方法来设置代理
自由设置Http头、强大的异步等待、强大的代理设置。。。这些相信操作网页的朋友们都会喜欢上它
下面是具体操作的代码
任务:1.登录论坛http://www.moonsclub.com
2.找个板块发帖
实战:
1.上论坛点登录-Httpwatch截包-分析Post参数<发现需要参数formhash,并且在源码里有>
2.随便找个板块发帖-截包-分析Post参数<发现需要参数formhash和posttime,在源码里同样存在;还有标题前面是[101229]明显是20101229去掉20后形成的;还要注意标题和内容都是UTF8编码的>
代码思路:
1.先GET登录入口获取参数formhash:http://www.moonsclub.com/logging.php?action=login&infloat=yes&handlekey=login&inajax=1&ajaxtarget=fwin_content_login；
2.Post数据到http://www.moonsclub.com/logging.php?action=login&loginsubmit=yes，然后根据返回的源码来判断登录是否成功，登录成功的话就获取服务器返回的Http头来找cookie；
3.根据返回的cookie，设置ServerXmlhttp的cookie然后GET板块地址，获取2个参数formhash和posttime；然后再Post发往http://www.moonsclub.com/post.php?action=newthread&fid=57&extra=&topicsubmit=yes
上代码:
'添加text1、text2、text3，分别是帐、密、发帖的返回值
Dim Login%, MyCookie$ '登录状态和cookie
Private Function XMLHttpRequest(ByVal XmlHttpMode, ByVal XmlHttpURL, ByVal XmlHttpData)
Dim MyXmlhttp
On Error GoTo wrong
Set MyXmlhttp = CreateObject("Msxml2.ServerXMLHTTP.6.0")
With MyXmlhttp
.setTimeouts 5000, 5000, 5000, 5000 '设置超时
If XmlHttpMode = "POST" Then '设置是GET方法还是POST方法,并且设置异步获取
.Open "POST", XmlHttpURL, True
Else
.Open "GET", XmlHttpURL, True
End If
If XmlHttpMode = "POST" Then
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
End If
If Login = 2 Then '登录成功后加上cookie,服务器才认为你是登录用户
.setRequestHeader "Referer", "http://www.moonsclub.com/post.php?action=newthread&fid=30&referer=http%3A//www.moonsclub.com/forumdisplay.php%3Ffid%3D30" '带上来路免得服务器说你非法来路哈哈
.setRequestHeader "Cookie", MyCookie
End If
.send XmlHttpData
.waitForResponse '设置异步等待
If MyXmlhttp.Status = 200 Then '返回的Http头200才是正常的
XMLHttpRequest = .responseText '设置responseText是自动UTF8解码的
If Login = 1 Then
If InStr(.responseText, "欢迎您回来") <> 0 Then '判断是否登录成功
Login = 2
MyCookie = GetCookie(.getAllResponseHeaders)
Else '登录失败
MsgBox "登录失败"
End If
End If
Else
'XMLHttpRequest = "Http错误代码:" & .Status
XMLHttpRequest = ""
End If
End With
Set MyXmlhttp = Nothing
Exit Function
wrong:
'XMLHttpRequest = "错误原因:" & Err.Description & ""
XMLHttpRequest = ""
Set MyXmlhttp = Nothing
End Function
Private Sub Command1_Click() '登录
Dim webcode$, PostDate$
Login = 0
webcode = XMLHttpRequest("GET", "http://www.moonsclub.com/logging.php?action=login&infloat=yes&handlekey=login&inajax=1&ajaxtarget=fwin_content_login", "") '这里先去获取参数formhash
If webcode = "" Then MsgBox "请检查网络连接": Exit Sub
a = InStr(webcode, "formhash"): b = InStr(a, webcode, "="): c = InStr(b + 2, webcode, """")
formhash = Mid(webcode, b + 2, c - b - 2)
Login = 1
PostDate = "formhash=" & formhash & "&loginfield=username&username=" & Text1.Text & "&password=" & Text2.Text & "&questionid=0&answer=&loginsubmit=%E7%99%BB%E5%BD%95"
Call XMLHttpRequest("POST", "http://www.moonsclub.com/logging.php?action=login&loginsubmit=yes", PostDate) '根据参数再提交登录
End Sub
Private Function GetCookie(str$) '处理cookie的函数,getResponseHeader方法只返回一个setcookie的明显不完整
Dim cookie$
a = InStr(str, "Set-Cookie: ") '没发现Set-Cookie直接返回空，说明服务器没返回Set-Cookie
If a = 0 Then
GetCookie = ""
Else
b = InStr(a, str, ";"): c = Mid(str, a + 12, b - a - 11)
cookie = c
Do '循环查找Set-Cookie，并把cookie值都串起来
d = InStr(b, str, "Set-Cookie: ")
If d = 0 Then Exit Do
e = InStr(d, str, ";"): f = Mid(str, d + 12, e - d - 11)
b = e
cookie = cookie & f
Loop
GetCookie = cookie
End If
End Function
Private Sub Post()
Dim webcode$, PostDate$, Title$, Content$
webcode = XMLHttpRequest("GET", "http://www.moonsclub.com/post.php?action=newthread&fid=30&referer=http%3A//www.moonsclub.com/forumdisplay.php%3Ffid%3D30", "") '还是老规矩获取参数
If webcode = "" Then MsgBox "请检查网络连接": Exit Sub
Text1.Text = webcode
a = InStr(webcode, "formhash"): b = InStr(a, webcode, "="): c = InStr(b + 2, webcode, """")
a1 = InStr(webcode, "posttime"): b1 = InStr(a1, webcode, "="): c1 = InStr(b1 + 1, webcode, """")
formhash = Mid(webcode, b + 1, c - b - 1): posttime = Mid(webcode, b1 + 1, c1 - b1 - 1)
Title = "[" & Replace(Year(Now), "20", "") & "]" & Month(Now) & Day(Now) & "这么晚了怎么还有这么多人在线呢" '这里最后的文字就是发帖的标题大家可以改一下我怕封所以瞎扯了个标题发。。
Content = "郁闷了~~" '这里就是帖子的内容
PostDate = "formhash=" & formhash & "&posttime=" & posttime & "&wysiwyg=0&iconid=&subject=" & UTF8EncodeURI(Title) & "&typeid=7&checkbox=0&message=" & UTF8EncodeURI(Content) & "&tags=&addtags=%2B%E5%8F%AF%E7%94%A8%E6%A0%87%E7%AD%BE"
Text3.Text = XMLHttpRequest("POST", "http://www.moonsclub.com/post.php?action=newthread&fid=57&extra=&topicsubmit=yes", PostDate) '这里能查看帖子有没有正常发出
End Sub
Private Sub Command2_Click() '发帖
Call Post
End Sub
Private Function UTF8EncodeURI(ByVal szInput As String) As String
Dim wch As String
Dim uch As String
Dim szRet As String
Dim x As Long
Dim inputLen As Long
Dim nAsc As Long
Dim nAsc2 As Long
Dim nAsc3 As Long
If szInput = "" Then
UTF8Encode = szInput
Exit Function
End If
inputLen = Len(szInput)
For x = 1 To inputLen
'得到每个字符
wch = Mid(szInput, x, 1)
'得到相应的UNICODE编码
nAsc = AscW(wch)
'对于<0的编码 其需要加上65536
If nAsc < 0 Then nAsc = nAsc + 65536
'对于<128位的ASCII的编码则无需更改
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
'真正的第二层编码范围为000080 - 0007FF
'Unicode在范围D800-DFFF中不存在任何字符，基本多文种平面中约定了这个范围用于UTF-16扩展标识辅助平面（两个UTF-16表示一个辅助平面字符）.
'当然，任何编码都是可以被转换到这个范围，但在unicode中他们并不代表任何合法的值。
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
'第三层编码00000800 – 0000FFFF
'首先取其前四位与11100000进行或去处得到UTF-8编码的前8位
'其次取其前10位与111111进行并运算，这样就能得到其前10中最后6位的真正的编码 再与10000000进行或运算来得到UTF-8编码中间的8位
'最后将其与111111进行并运算，这样就能得到其最后6位的真正的编码 再与10000000进行或运算来得到UTF-8编码最后8位编码
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
UTF8EncodeURI = szRet
End Function
有什么不清楚的可以留言
附:
Xmlhttp手册下载地址:http://www.sunshinebean.com/upload/v.asp?id=64
ServerXmlhttp手册下载地址:http://www.sunshinebean.com/upload/v.asp?id=63
本文用到的截包工具HttpWatch下载地址:http://download.csdn.net/source/2688506