xmlhttp.asp

在线邮件列表抓取与发送系统SQL版

<%
On Error Resume Next
Server.ScriptTimeOut=9999999
Function getHTTPPage(Path)
        t = GetBody(Path)
        getHTTPPage=BytesToBstr(t,"GB2312")
End function

Function bytes2BSTR(vIn)
strReturn = "" 
For j = 1 To LenB(vIn) 
ThisCharCode = AscB(MidB(vIn,j,1)) 
If ThisCharCode < &H80 Then 
strReturn = strReturn & Chr(ThisCharCode) 
Else 
NextCharCode = AscB(MidB(vIn,j+1,1)) 
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode)) 
j = j + 1 
End If 
Next 
bytes2BSTR = strReturn 
End Function 

Function GetBody(url) 
        on error resume next
        Set Retrieval = CreateObject("Microsoft.XMLHTTP") 
         
       Retrieval.Open "Get", url, False, "", "" 
       Retrieval.Send 
       GetBody =Retrieval.responsebody
        
        Set Retrieval = Nothing 
End Function

Function BytesToBstr(body,Cset)
        dim objstream
        set objstream = Server.CreateObject("adodb.stream")
        objstream.Type = 1
        objstream.Mode =3
        objstream.Open
        objstream.Write body
        objstream.Position = 0
        objstream.Type = 2
        objstream.Charset = Cset
        BytesToBstr = objstream.ReadText 
        objstream.Close
        set objstream = nothing
End Function
Function Newstring(URLBody,strng)
        Newstring=Instr(lcase(URLBody),lcase(strng))
        if Newstring<=0 then Newstring=Len(URLBody)
End Function
%>