清风发布于： http://blog.csdn.net/anwell/archive/2005/12/23/560005.aspx
转载请注明出处，谢谢！
偶有闲瑕，做了个希网邮件列表小偷程序，郁闷的是希网的图片调用不出来：（，发出来与大家交流。
<%'by 清风 QQ: 97090444 MSN:anwellsz@msn.com 转载请注明出处，欢迎交流！On Error Resume Next '忽略错误Server.ScriptTimeOut=9999999 '设置脚本超时时间Dim ListNameListName = "workszptt" '邮件列表名称，可以换成你在希网上的邮件列表名称select case request("action") case "view" show case else showlistend SelectFunction showlist '显示具体条目 dim lsstart,lsend,lsstr,lstemp lsstr=getHTTPPage("http://www.cn99.com/cgi-bin/get_lsts?listname="&ListName) lsstart=instr(lsstr,"【下面是您要查询的列表") lsend = instr(lsstr,"<BR></p>") lstemp=mid(lsstr,lsstart,lsend-lsstart) lstemp = Replace(lstemp,"catalog?","http://www.cn99.com/cgi-bin/catalog?") lstemp = Replace(lstemp,"getmsg?listname="&ListName&"&id=","qikan.asp?action=view&id=") lstemp = Replace(Replace(lstemp,"<TR><TD colspan=""6""> </TD></TR>",""),"#FFE0C0","#CCCCCC") lstemp = Replace(lstemp,"FFF8F0","#F2F2F2") response.write lstempend FunctionFunction show '显示详细信息 dim lsstr lsstr=getHTTPPage("http://www.cn99.com/cgi-bin/getmsg/body?listname="&ListName&"&id="&request("id")) lsstart = InStr(lsstr,"<BODY bgColor=#ffffff leftMargin=6 topMargin=4>")+47 lsend = InStr(lsstr,"个订户")+3 lstemp = Mid(lsstr,lsstart,lsend-lsstart) lstemp = Replace(lstemp,"/cgi-bin/getmsg/rel?listname="&ListName&"&id=","http://www.cn99.com/cgi-bin/getmsg/rel?listname="&ListName&"&id=") Response.write lstempend functionFunction getHTTPPage(url) dim http set http=Server.createobject("Microsoft.XMLHTTP") Http.open "GET",url,false Http.send() if Http.readystate<>4 then exit function end if getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") set http=nothingEnd functionFunction PostHTTPPage(url,strForm) dim http set http=Server.createobject("Microsoft.XMLHTTP") Http.open "POST",url,false http.setRequestHeader "Content-Length",len(strForm) http.setRequestHeader "Content-Type","application/x-www-form-urlencoded" Http.send(strForm) if Http.readystate<>4 then exit function end if PostHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") set http=nothingEnd functionFunction 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 = nothingEnd Function%>
