VBS采集：抓取一本电子书

VBS采集：抓取一本电子书

(2011-05-30 00:00:00)

最近没事儿就搜电子书，然后在地铁里打发时间。发现了凤凰网读书频道里有不少好资源，遂促成此文。

'Function:本程序为VBS采集演示
'Author:Dodo
'From:http://vbs.
'Comment:还有很多重构的余地;是入门者极好的学习素材;欢迎交流
'CreateDate:2011.05.30
'扯蛋：鸣谢凤凰网读书频道

Set HTTP=CreateObject("Msxml2.XMLHTTP")
Set Re=New RegExp

'@Function 获取HTML代码
Function  getHtml(URL)
 Dim content
    With HTTP
  .open "GET", URL, False : .setRequestHeader "If-Modified-Since","0" : .send : content= .responseText
    End With
    getHtml=content
End Function

'@Function 获取title
Function getTitle(str)
 With Re
        .Global=True : .IgnoreCase=True
        .Pattern="<h1>([^<]*)<"
        Set goldWords= .Execute(str)
    End With
 Dim title
    title=goldWords(0).subMatches(0)
 getTitle=title
End Function

'@Sub 筛选所需内容
Sub getWords(str)
    With Re
        .Global=True : .IgnoreCase=True
        .Pattern="<p>(.*)"
        Set goldWords= .Execute(str)
    End With
    Dim i
    i=0
    For Each w In goldWords
        words(i)=w.subMatches(0) : i=i+1       
    Next
End Sub

'@function 过滤字符
function htmlFilter(str)
 str=Trim(str)
 str=Replace(str,"</p><p>",vbCrLf)
 str=Replace(str,"<br />",vbCrLf)
 str=Replace(str,"<br/>",vbCrLf)
 str=Replace(str,"<p>","")
 str=Replace(str,"</p>","")
 htmlFilter=str
End Function

'@Sub 写入记事本
Sub write(str)
 Set WS=CreateObject("Wscript.Shell")
 desktopPath=WS.SpecialFolders("desktop")
 Set FSO=CreateObject("Scripting.FileSystemObject")
 Set pencil=FSO.OpenTextFile(desktopPath & "\不想做空姐.txt",8,1)
 pencil.Write  str

 WS.Popup "保存不想做空姐.txt",1,"操作完毕",64
End Sub

'@Sub 调试输出
Sub mb(str,data)
 'MsgBox "DebugInfo_" & str &": "& data
End Sub

'@Sub 结束提示
Sub proEnd()
 MsgBox "运行结束"
End Sub

'@Sub 抓一下
Sub fetchOnce(URL)
 Dim content
 Dim title
 'URL = "http://book.ifeng.com/lianzai/detail_2011_05/16/6419310_1.shtml"
 
 content=getHtml(URL)
                   Call mb("content",content)
 title=getTitle(content)'获取标题
 beginFlag=InStr(content,"<!--mainContent begin-->")
                   Call mb("beginFlag",beginFlag)
 content=Mid(content,beginFlag+24,1000000)
 endFlag=InStr(content,"<!--mainContent end-->")-1
                   Call mb("endFlag",endFlag)
                   Call mb("content",content)
 content=Mid(content,1,endFlag)
 'getWords(content)
                   Call mb("content",content)
 content=htmlFilter(content)& vbCrLf
 title=vbCrLf & vbCrLf & "【" & htmlFilter(title) & "】" & vbCrLf
 write(title  & content )

End Sub

'@Sub 执行入口
Sub main()
 For n=1 To 71
  URL = "http://book.ifeng.com/lianzai/detail_2011_05/16/6419310_"& n &".shtml"
  fetchOnce(URL)
 Next
 proEnd()
End Sub

main()