'添加text1、text2、text3，分别是帐、密、发帖的返回值 Dim Login%, MyCookie$ '登录状态和cookie
Private Function XMLHttpRequest(ByVal XmlHttpMode, ByVal XmlHttpURL, ByValXmlHttpData) 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", "&fid=30&referer=http%3A//%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 SubCommand1_Click() '登录 Dim webcode$, PostDate$
Login = 0 webcode = XMLHttpRequest("GET", "&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", "&loginsubmit=yes", PostDate) '根据参数再提交登录 End Sub
Private FunctionGetCookie(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", "&fid=30&referer=http%3A//%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", "&fid=57&extra=&topicsubmit=yes", PostDate) '这里能查看帖子有没有正常发出 End Sub
Private SubCommand2_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
