百度博客目录提取工具（HTM版）

罗ぷ曼ㄉ帝Ke · 发表于 2009-12-2 00:14:31

<html><head>
<title>HTML版目录提取工具</title></head>
<style type='text/css'> body{font-size: 10pt;} a{color: #000000;text-decoration : none;font-size: 10pt;} a:hover {color: red;text-decoration : underline;} td{color: #000000;text-decoration : none;font-size: 10pt;}
</style>

<SCRIPT LANGUAGE="JavaScript">

</SCRIPT>

<Script language=VBScript>
dim datec,leic,htmc,username
dim IDnum
Function bytes2BSTR(vIn) 'utf8转换函数
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
next
bytes2BSTR = jmtiqu(strReturn)

End Function

Function dq(start)'远程抓取函数
dim XmlHttp
zifu=split(start,"|")
datec=zifu(6)
leic=zifu(7)
htmc=zifu(5)
username=zifu(2)
If zifu(3)="true" then
FileUrl1 = "http://hi.baidu.com/" & URLEncoding(username) & "/blog/category/" & zifu(4) & "/index/"
else
FileUrl1 = "http://hi.baidu.com/" & URLEncoding(username) & "/blog/index/"
end if

if datec="true" then
BiaoTouD="<td>时间</td>"
else
BiaoTouD=""
end if

if leic="true" then
BiaoTouL="<td>类别</td>"
else
BiaoTouL=""
end if

sminfo.innerHTML = "<h4 align=center>" & zifu(2) & "的博客目录</h4><hr><div align='center'><table border=1><tr align=center><td>ID</td><td>文章目录</td>" & BiaoTouD & BiaoTouL & "</tr>" & vbCrLf
IDnum=1
for k=int(zifu(0)) to int(zifu(1))
url=FileUrl1 & k
set XmlHttp = CreateObject("Microsoft.XMLHTTP")
XmlHttp.Open "GET",url, false
XmlHttp.setRequestHeader "Content-Type","text/XML"
XmlHttp.Send
dq = bytes2BSTR(XmlHttp.responseBody)
next

sminfo.innerHTML =sminfo.innerHTML + "</table></div><br><p><hr><center><A href='http://hi.baidu.com/jmdcw' target=_blank> JMDCW </a>制作-- 2007.06 </center></body></html>"
End Function

Function JmTiQu(BaiHtml) '提取相关内容，JMDCW编写
Dim BaiDu
UrlStart = "<div class=" & Chr(34) & "tit" & Chr(34) & "><a href=" & Chr(34) & "/"
Const UrlEnd = "/"
NameStart = Chr(34) & " target=" & Chr(34) & "_blank" & Chr(34) & ">"
Const NameEnd = "</a></div>"
DataStart = "<div class=" & Chr(34) & "date" & Chr(34) & ">"
LeiStart = Chr(34) & ">类别："
ChaXu1 = UrlStart & URLEncoding(UserName) & UrlEnd
BaiDu = ""

Startme = 1 '定义首先为1位
Do While Startme <> 0
Where1 = InStr(Startme, BaiHtml, ChaXu1) '得到HTML的头部
Startme = Where1
If Startme = 0 Then Exit Do
Where2 = InStr(Startme, BaiHtml, NameStart) '得到HTLM的尾部
Startme = Where2
If Startme = 0 Then Exit Do
Where3 = InStr(Startme, BaiHtml, NameEnd) '得到文章的尾部
Startme = Where3
If Startme = 0 Then Exit Do
Where4 = InStr(Startme, BaiHtml, DataStart) '得到日期的头部
Startme = Where4
If Startme = 0 Then Exit Do
Where5 = InStr(Startme, BaiHtml, "</div>") '得到日期的尾部
Startme = Where5
If Startme = 0 Then Exit Do
Where6 = InStr(Startme, BaiHtml, LeiStart) '得到类别的头部
Startme = Where6
If Startme = 0 Then Exit Do
Where7 = InStr(Startme, BaiHtml, "</a>") ' 得到类别的尾部
Startme = Where7

If Where7 <> 0 Then
'BaiHtmStr = Mid(BaiHtml, Where1 + Len(ChaXu1), (Where2 - Where1 - Len(ChaXu1))) 'html
'BaiHtmStr = "http://hi.baidu.com/" & URLEncoding(UserName) & "/" & BaiHtmStr
BaiFileStr = Mid(BaiHtml, Where2 + Len(NameStart), (Where3 - Where2 - Len(NameStart))) '文章

BaiDu = BaiDu & "<tr><td>" & IDnum & "</td>"

if htmc="true" then
BaiHtmStr = Mid(BaiHtml, Where1 + Len(ChaXu1), (Where2 - Where1 - Len(ChaXu1))) 'html
BaiHtmStr = "http://hi.baidu.com/" & URLEncoding(UserName) & "/" & BaiHtmStr
BaiDu = BaiDu & "<td><a href='" & BaiHtmStr & "' target='_blank'>" & BaiFileStr & "</a></td>"
else
BaiDu = BaiDu & "<td>" & BaiFileStr & "</td>"
end if
' BaiDu = BaiDu & "<tr><td><a href='" & BaiHtmStr & "' target='_blank'>" & BaiFileStr & "</a></td>"
if datec="true" then
BaiDate = Mid(BaiHtml, Where4 + Len(DataStart), (Where5 - Where4 - Len(DataStart))) '日期
BaiDate = Left(BaiDate, 11) & " " & Right(BaiDate, 5)
BaiDu = BaiDu & "<td>" & BaiDate & "</td>"
end if

if leic="true" then
BaiLei = Mid(BaiHtml, Where6 + Len(LeiStart), (Where7 - Where6 - Len(LeiStart))) '类别
BaiDu = BaiDu & "<td>" & BaiLei & "</td>"
end if

BaiDu = BaiDu & "</tr>"
IDnum=IDnum+1
End If
Loop
sminfo.innerHTML = sminfo.innerHTML + BaiDu
End Function

Function URLEncoding(vstrin) '转换汉字为十六进制字符，来源于网络
StrReturn = ""
Dim i
For i = 1 To Len(vstrin)
ThisChr = Mid(vstrin, i, 1)
If Abs(Asc(ThisChr)) < &HFF Then
StrReturn = StrReturn & ThisChr
Else
InnerCode = Asc(ThisChr)
If InnerCode < 0 Then
InnerCode = InnerCode + &H10000
End If
Hight1 = (InnerCode And &HFF00) \ &HFF
Low1 = InnerCode And &HFF
StrReturn = StrReturn & "%" & Hex(Hight1) & "%" & Hex(Low1)
End If
Next
URLEncoding = StrReturn
End Function

</script>

<body>
<div align="center"><font color=red>HTML版目录提取工具</font><br>
<FORM METHOD=POST ACTION="" name="frm2">
开始页次：<input type="text" name="startnum" size=3 id="startnum"> 结束页次<input type="text" name="endnum" size=3 id="endnum"><br>
用户的域名： <input type="text" name="host" id="host"><br>
高级：<input type="checkbox" name="checkMulu" id="checkMulu">按分类提取 <input type="text" name="TexMulu" size=12 value="默认分类" id="TexMulu"><br>
生成目录选项 <input type="checkbox" name="checkHtm" id="checkHtm" checked>链接
<input type="checkbox" name="checkDate" id="checkDate" checked>时间
<input type="checkbox" name="checkLei" id="checkLei" checked>分类 <br>
<INPUT TYPE="button" value=" 提取 " name="btnchk" onclick="chkacc();">
</FORM></div>
<div id="sminfo"></div>

</body>

</html>

oscar · 发表于 2010-1-29 04:05:04

虎躯一震，三分走人

		自动登录	找回密码
密码			注册