用这个函数可以:
' - - - - - - 解决XML HTTP发送中文的问题 - - - - -
' 用XMLHTTP Post Form时的表单乱码有两方面的原因——Post表单数据
' 时中文乱码;服务器Response被XMLHTTP不正确编码引起的乱码。
Function URLEncoding(vstrIn)
Dim strreturn,ThisChr,innerCode,Hight8,Low8,i
strReturn = ""
For i = 1 To Len(vstrIn)
ThisChr = Mid(vStrIn,i,1)
If Abs(Asc(ThisChr)) < &HFF Then
strReturn = strReturn & ThisChr
Else
innerCode = Asc(ThisChr)
If innerCode < 0 Then
innerCode = innerCode + &H10000
End If
Hight8 = (innerCode And &HFF00)\ &HFF
Low8 = innerCode And &HFF
strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strReturn
End Function
' - - - - - 解决XML HTTP反馈问题- - - - - -
' 将反馈的xml.responsebody反编码
Function bytes2BSTR(vIn)
Dim strReturn,ThisCharCode,NextCharCode,i
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function
' - - - - - - 服务器向下级列表分发规则函数- - - - - -
' 首先获取下级服务器列表
Public Function RuleSend(rulesql,ruletype)
Dim xmlhttp,xmltext,strsqls,IPrs
strsqls = "select ID,ClientIP from t_depart_main where isover<>'1'"
Set IPrs = Server.CreateObject("ADODB.recordset")
IPrs.open strsqls,objconn,1,1
If not IPrs.eof then
'response.Redirect("http://"&objrs("ClientIP")&"/uprule.asp?strsql="&rulesql&"&type="&ruletype)
'EDIT RECORD
'=========================================
'EditDate: 2003-09-26
'Editor: KOON
'Action: 说明
'Reason: 本来此程序写到这里已经无法继续下去,因为HTTP不能得到回复
' 鉴于HTTP的特性,我们无法保持服务器与服务器的通讯
' 起先打算使用XML PRC,后来发现没有必要那么麻烦,使用XML HTTP就可以
'Result: 参照XML SDK,写两个通讯的ASP,注意解码就是了
'=========================================
'进行XML规则的分发
Set xmlhttp = server.CreateObject("MSXML2.XMLHTTP")
xmltext = URLEncoding("Submit="&ruletype&"&strsql="&server.URLEncode(rulesql))
For i = 1 to IPrs.recordcount
xmlhttp.open "post","http://"&IPrs("ClientIP")&"/processrule.asp","False"
xmlhttp.setRequestHeader "Content-Length",len(xmltext)
xmlhttp.setRequestHeader "CONTENT-TYPE","application/x-www-form-urlencoded"
xmlhttp.send(xmltext)
IPrs.movenext
Next
'response.Write(IPrs("ClientIP"))
'response.Write(xmlhttp.readyState)
'response.Write(xmlhttp.status)
Call Msgcount(bytes2BSTR(xmlhttp.responsebody))
Else
Call Msgcount("没有下级服务器注册,此规则只能用于本级服务器...")
End If
End Function