有些人當抓取程序是個寶，到目前還TND有人在賣錢，強烈BS一下這些家伙 真是的！可能偶下邊這段東西比較爛哈
下邊這個沒有寫入庫功能，已經到這一步了，入庫功能是很簡單的事了，需要的請自己去完成吧，其它功能各位自行完善吧！把代碼拷貝過去直接運行即可看到效果
Dim Url,List_PageCode,Array_ArticleID,i,ArticleID
Dim Content_PageCode,Content_TempCode
Dim Content_CategoryID,Content_CategoryName,BorderID,ClassID,BorderName,ClassName
Dim ArticleTitle,ArticleAuthor,ArticleFrom,ArticleContent
Url = "http://www.webasp.net/article/class/1.htm"
List_PageCode = getHTTPPage(Url)
List_PageCode = RegExpText(List_PageCode,"打印/th>/tr>","/table>table border=0 cellpadding=5",0)
List_PageCode = RegExpText(List_PageCode,"td align=left>a href='../","'>img border=0 src='../images/authortype0.gif'",1) '取得當前列表頁的文章鏈接，以,分隔
Array_ArticleID = Split(List_PageCode,",") '創建數組，存儲文章ID
For i=0 To Ubound(Array_ArticleID)-1
ArticleID = Array_ArticleID(i) '文章ID
Content_PageCode = getHTTPPage("http://www.webasp.net/article/"ArticleID) '取得文章頁的內容
'=========取文章分類及相關ID參數 開始=======================
Content_TempCode = RegExpText(Content_PageCode,"a href=""/article/"">技術教程/a> gt;gt; ","gt;gt; 內容/td>",0)
Content_CategoryID = RegExpText(Content_PageCode,"a href='../class","/'>",1)
BorderID = Split(Content_CategoryID,",")(0) '大類ID
ClassID = Split(Content_CategoryID,",")(1) '子類ID
'==========檢查大類是否存在 開始===============
'如果不存在則入庫
'==========檢查大類是否存在 結束===============
'Response.Write(BorderID "," ClassID "br />")
Content_CategoryName = RegExpText(Content_PageCode,"/'>","/a>",1)
BorderName = Split(Content_CategoryName,",")(0) '大類名稱
ClassName = Split(Content_CategoryName,",")(1) '子類名稱
'==========檢查子類是否存在 開始===============
'如果不存在則入庫
'==========檢查子類是否存在 結束===============
'=========取文章分類及相關ID參數 結束=======================
'=========取文章標題及內容 開始=============================
ArticleTitle = RegExpText(Content_PageCode,"tr>td align=center bgcolor=#DEE2F5>strong>","/strong>/td>/tr>",0)
ArticleAuthor = RegExpText(Content_PageCode,"tr>td>span class=blue>作者：/span>","/td>/tr>",0)
ArticleFrom = RegExpText(Content_PageCode,"tr>td>span class=blue>來源：/span>","/td>/tr>",0)
ArticleContent = RegExpText(Content_PageCode,"tr>td class=content style=""WORD-WRAP: break-word"" id=zoom>","/td>/tr>"VBCrlf" /table>"VBCrlf" /td>/tr>/table>",0)
'=========取文章標題及內容 結束=============================
Response.Write(ArticleTitle "br />br />")
Response.Flush()
Next
附幾個函數：
Function getHTTPPage(url)
IF(IsObjInstalled("Microsoft.XMLHTTP") = False)THEN
Response.Write "br>br>服務器不支持Microsoft.XMLHTTP組件"
Err.Clear
Response.End
END IF
On Error Resume Next
Dim http
SET http=Server.CreateObject("Msxml2.XMLHTTP")
Http.open "GET",url,False
Http.send()
IF(Http.readystate>4)THEN
Exit Function
END IF
getHTTPPage=BytesToBSTR(Http.responseBody,"GB2312")
SET http=NOTHING
IF(Err.number>0)THEN
Response.Write "br>br>獲取文件內容出錯"
'Response.End
Err.Clear
END IF
End Function
Function BytesToBstr(CodeBody,CodeSet)
Dim objStream
SET objStream = Server.CreateObject("adodb.stream")
objStream.Type = 1
objStream.Mode =3
objStream.Open
objStream.Write CodeBody
objStream.Position = 0
objStream.Type = 2
objStream.Charset = CodeSet
BytesToBstr = objStream.ReadText
objStream.Close
SET objStream = NOTHING
End Function
'================================================
'作 用：檢查組件是否已經安裝
'返回值：True ----已經安裝
' False ----沒有安裝
'================================================
Function IsObjInstalled(objName)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim testObj
SET testObj = Server.CreateObject(objName)
IF(0 = Err)THEN IsObjInstalled = True
SET testObj = NOTHING
Err = 0
End Function
Function RegExpText(strng,strStart,strEnd,n)
Dim regEx,Match,Matches,RetStr
SET regEx = New RegExp
regEx.Pattern = strStart"([\s\S]*?)"strEnd
regEx.IgnoreCase = True
regEx.Global = True
SET Matches = regEx.Execute(strng)
For Each Match in Matches
IF(n=1)THEN
RetStr = RetStr regEx.Replace(Match.Value,"$1") ","
ELSE
RetStr = RetStr regEx.Replace(Match.Value,"$1")
END IF
Next
RegExpText = RetStr
SET regEx=NOTHING
End Function
