站内首页 > 网页前端 > ASP > 正文

采集类及例子可灵活结合自定函数

 

复制内容到剪贴板
  1. <%   
  2. function getHTTPPage(url,cset)   
  3.     dim Http   
  4.     set Http=server.createobject("MSXML2.XMLHTTP")   
  5.     Http.open "GET",url,false   
  6.     Http.send()   
  7.     if Http.readystate<>4 then    
  8.         exit function   
  9.     end if   
  10.     getHTTPPage=bytesToBSTR(Http.responseBody,cset)   
  11.     set http=nothing   
  12.     if err.number<>0 then err.Clear    
  13. end function   
  14. Function BytesToBstr(body,cset)   
  15.         dim objstream   
  16.         set objstream = Server.CreateObject("adodb.stream")   
  17.         objstream.Type = 1   
  18.         objstream.Mode =3   
  19.         objstream.Open   
  20.         objstream.Write body   
  21.         objstream.Position = 0   
  22.         objstream.Type = 2   
  23.         objstream.Charset = cset   
  24.         BytesToBstr = objstream.ReadText    
  25.         objstream.Close   
  26.         set objstream = nothing   
  27. End Function  
  28. Function HTMLEncode(reString) '转换HTML代码   
  29.  Dim Str:Str=reString   
  30.  If Not IsNull(Str) Then  
  31.   'Str = Replace(Str,CHR(9), "")   
  32.   'Str = Replace(Str,CHR(13), "")   
  33.   'Str = Replace(Str,CHR(10), "")   
  34.   'Str = Replace(Str,CHR(32), " ")     
  35.   kongge=""  
  36.   'del=""   
  37.   'for i=1 to 20   
  38.   'kongge=kongge&CHR(32)   
  39.   'del=kongge   
  40.   'Str = Replace(Str,kongge, " ")     
  41.   'next   
  42.   Str = Replace(Str,CHR(32)&CHR(32), " ")     
  43.   Str = Replace(Str,"> <", "><")     
  44.   Str = Replace(Str," <", "<")     
  45.   Str = Replace(Str," >", ">")     
  46.   Str = Replace(Str," >", ">")     
  47.   Str = Replace(Str,CHR(34),CHR(39))     
  48.   HTMLEncode = Str     
  49.  End If  
  50. End Function  
  51. '==================================================   
  52. '函数名：GetBody   
  53. '作  用：截取字符串   
  54. '参  数：ConStr--将要截取的字符串   
  55. '参  数：StartStr--开始字符串   
  56. '参  数：OverStr--结束字符串   
  57. '参  数：IncluL--是否包含StartStr   
  58. '参  数：IncluR--是否包含OverStr   
  59. '==================================================   
  60. Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)   
  61.    If ConStr="$Falsecontentquot; or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then  
  62.       GetBody="$Falsecontentquot;  
  63.       Exit Function  
  64.    End If  
  65.    Dim ConStrTemp   
  66.    Dim Start,Over   
  67.    ConStrTemp=Lcase(ConStr)   
  68.    StartStr=Lcase(StartStr)   
  69.    OverStr=Lcase(OverStr)   
  70.    Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)   
  71.    If Start<=0 then   
  72.       GetBody=""  
  73.       Exit Function  
  74.    Else  
  75.       If IncluL=False Then  
  76.          Start=Start+LenB(StartStr)   
  77.       End If  
  78.    End If  
  79.    Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)   
  80.    If Over<=0 Or Over<=Start then   
  81.       GetBody="$Falsecontentquot;  
  82.       Exit Function  
  83.    Else  
  84.       If IncluR=True Then  
  85.          Over=Over+LenB(OverStr)   
  86.       End If  
  87.    End If  
  88.    GetBody=MidB(ConStr,Start,Over-Start)   
  89. End Function  
  90. '==================================================   
  91. '函数名：LoseATag   
  92. '作  用：正则表达式过滤 链接<a>标记   
  93. '参  数：ContentStr ------将要截取的字符串   
  94. '==================================================   
  95. Function LoseATag(ContentStr)   
  96.      Dim ClsTempLoseStr,regEx   
  97.     ClsTempLoseStr = Cstr(ContentStr)   
  98.      Set regEx = New RegExp   
  99.      regEx.Pattern = "<(\/){0,1}a[^<>]*>"  
  100.      regEx.IgnoreCase = True  
  101.      regEx.Global = True  
  102.      ClsTempLoseStr = regEx.Replace(ClsTempLoseStr,"")   
  103.      LoseATag = ClsTempLoseStr   
  104.      Set regEx = Nothing  
  105. End Function  
  106. '==================================================   
  107. '函数名：ReplaceText   
  108. '作  用：批量替换字符串   
  109. '参  数：strHTML ------将要截取的字符串   
  110. '==================================================   
  111. function ReplaceText(strHTML,patrn,replStr)   
  112.    Set regEx = New RegExp ' 建立正则表达式   
  113.    regEx.Pattern = patrn   ' 设置模式   
  114.    regEx.IgnoreCase = True ' 设置是否区分大小写   
  115.    regEx.Global = True     ' 设置全局可用性   
  116. ReplaceText = regEx.Replace(""&strHTML"","") ' 作替换   
  117.    Set reg=nothing   
  118. End function   
  119. '==================================================   
  120. '函数名：ReadFromUTF   
  121. '作  用：读取文本文件内容,这个函数的优点在于可以读取gb2312编码格式的文件   
  122. '参  数：TempString要读取的模板文件路径; Charset是编码,一般是gb2312或者GB2312   
  123. '==================================================   
  124. function ReadFromUTF (TempString,CharSet)   
  125.      dim str   
  126.      set stm=server.CreateObject("adodb.stream")   
  127.      stm.Type=2    
  128.      stm.mode=3    
  129.      stm.charset=CharSet   
  130.      stm.open   
  131.      stm.loadfromfile server.MapPath(TempString)   
  132.      str=stm.readtext   
  133.      stm.Close   
  134.      set stm=nothing   
  135.      ReadFromUTF=str   
  136. end function   
  137. '==================================================   
  138. '函数名：字符串截取函数   
  139. '作  用：截取字符串内容   
  140. '参  数：Start要截取字符串开始; Last要截取字符串结束(如果结束为空，只取Start的split);num取第几个内容(从0开始)   
  141. '==================================================   
  142. Function GetKey(HTML,Start,Last,num)    
  143. filearray=split(HTML,Start)    
  144. if Last<>"" then   
  145.    if UBound(filearray)>0 and num<UBound(filearray) then   
  146.      filearray2=split(filearray(1),Last)    
  147.      GetKey=filearray2(num)   
  148.    else   
  149.      GetKey=UBound(filearray)   
  150.    end if    
  151. else   
  152.    GetKey=filearray(num)   
  153. end if   
  154. End Function  
  155. '例子   
  156. 'WHtml=ReadFromUTF("101290101.htm","utf-8")   
  157. 'Wurl="http://www.weather.com.cn/html/weather/"&cnid&".shtml"   
  158. 'WHtml=GetHttpPage(Wurl)   
  159. 'WHtml=HTMLEncode(WHtml)   
  160. 'WHtml=Replace(WHtml,"<a class='cyclePrediction'>","<font color=red>")  '对星期六、天进行颜色替换   
  161. 'WHtml=LoseATag(WHtml)   '去除超链接   
  162. 'dateinfo=GetBody(WHtml,"<h1 class='weatheH1'>","发布",False,True)   
  163.   
  164. '例子   
  165. 'dim myThief,page,aa,id   
  166. 'aa=request("aa")   
  167. 'id=request("id")   
  168. 'set myThief=new clsThief    
  169. 'myThief.src="http://hd.openv.com/inc/"&aa&"maker.php?id="&id&""   
  170. 'myThief.steal   
  171. 'myThief.cut "<!-- big img end -->","<!-- 合作 开始 -->"   
  172. 'title=GetKey(myThief.value,"<title>","</title>")   
  173. 'myThief.change "tv_show-","show.asp?id="   
  174. 'page=myThief.value '获得偷取的内容   
  175. 'set myThief=nothing '释放对象   
  176. %>   
  177. <%    
  178. 'if request("id")="" then   
  179. 'Response.write("<script >alert('对不起！您未输入相关信息！');history.back(-1);</script>")   
  180. 'response.End()   
  181. 'else   
  182. 'cnid=request("id")   
  183. 'WHtml=ReadFromUTF("101290101.htm","utf-8")   
  184. imgurl="www.qiyipic.com"  
  185. Wurl="http://www.qiyi.com/dianying/index.html"  
  186. WHtml=GetHttpPage(Wurl,"utf-8")   
  187. 'WHtml=HTMLEncode(WHtml)   
  188. 'WHtml=LoseATag(WHtml)   '去除超链接   
  189. WHtml=Replace(WHtml,"http://www.qiyipic.com/dianying","/img.asp?img="&imgurl"/dianying")   
  190. WHtml=Replace(WHtml,"http://www.qiyipic.com/common","/img.asp?img="&imgurl"/common")   
  191. WHtml=Replace(WHtml,"http://www.qiyipic.com/thumb","/img.asp?img="&imgurl"/thumb")   
  192. mmm=GetBody(WHtml,"<LINK href=","<!-- 标准尾 begin -->",True,False)   
  193. main=GetBody(WHtml,"<!-- 头部搜索区域 -->","<!-- 标准尾 begin -->",True,False)   
  194. ggg=GetBody(main,"<iframe","</iframe>",True,True)   
  195. main=Replace(main,ggg,"")   
  196. 'end if   
  197. %>   
  198. <%   
  199. 'var IPData = new Array("58.242.83.181","","安徽省","淮北市");   
  200. ipurl="http://fw.qq.com/ipaddress"  
  201. ipHtml=GetHttpPage(ipurl,"gb2312")   
  202. 'WHtml=HTMLEncode(WHtml)   
  203. 'WHtml=LoseATag(WHtml)   '去除超链接   
  204.   
  205. ipHtml=Replace(ipHtml,"http://www.qiyipic.com/dianying","/img.asp?img="&imgurl"/dianying")   
  206. mmm=GetBody(ipHtml,"new Array(",");",False,False)   
  207. mmm=Replace(mmm,"""","")   
  208. 'aa=split(mmm,",")   
  209. For i = 0 To 3   
  210. Response.Write getkey(mmm,",","",i)& "<br>"  
  211. Next  
  212. %>   

 

<< ASP 二级联动下拉框ASP控制虚拟主机函数ADSI >>
查看所有评论