为PJBlog增加Ping功能

2009年6月30日 | 分类: 代码如诗 | 标签: , ,

打开blogpost.asp,搜索:

Set lArticle = Nothing

在其后加入以下代码:

[code]Const PingContent=
"http://www.feedsky.com/api/RPC2|http://blog.yodao.com/ping/RPC2
|http://api.my.yahoo.com/RPC2|http://blogsearch.google.com/ping/RPC2
|http://www.xianguo.com/xmlrpc/ping.php|http://www.zhuaxia.com/rpc/server.php
|http://ping.blog.qikoo.com/rpc2.php|http://blog.iask.com/RPC2
|http://rpc.pingomatic.com"

Function SendPing

Dim Url,Urls
Urls=Split(Replace(PingContent,vbCr,""),"|")

For Each Url In Urls
If Trim(Url)<>"" Then
Call SendPing_Single(url)
End If
Next

End Function

Function SendPing_Single(url)

On Error Resume Next

Dim s,sUrl
If blog_postFile = 2 Then
sUrl = siteURL&"article/"&postLog(2)&".htm"
else
sUrl = siteURL&"default.asp?id="&postLog(2)
end if
s = "weblogUpdates.ping "&SiteName&" "&sUrl&"
"

Response.Write "

发送Ping到:" & Url & "

"
Response.Flush

Dim objPing
Set objPing = Server.CreateObject("MSXML2.ServerXMLHTTP")
objPing.SetTimeOuts 10000, 10000, 10000, 10000
'第一个数值:解析DNS名字的超时时间10秒
'第二个数值:建立Winsock连接的超时时间10秒
'第三个数值:发送数据的超时时间10秒
'第四个数值:接收response的超时时间10秒

objPing.open "POST",url,False

objPing.setRequestHeader "Content-Type", "text/xml"
objPing.send s

Set objPing = Nothing

Err.Clear

End Function

Call SendPing
%>[/code]

OK了,简单吧…..

目前还没有任何评论.