google sitemap.asp

用于生成sitemap.xml文件的东西，利于google等搜索引擎的抓取。

<%
server.scripttimeout=50000
' sitemap_gen.asp
' a simple script to automatically produce sitemaps for a webserver, in the google sitemap protocol (gsp)
' by francesco passantino
' www.iteam5.net/francesco/sitemap
' v0.2 released 5 june 2005 (listing a directory tree recursively improvement)
'
' bsd 2.0 license,
' http://www.opensource.org/licenses/bsd-license.php
' 收集整理:重庆森林@im286.com
session("server")="//www.jb51.net"
'你的域名
vdir = "/"
'制作sitemap的目录,相对目录(相对于根目录而言)
set objfso = createobject("scripting.filesystemobject")
root = server.mappath(vdir)

'response.contenttype = "text/xml"
'response.write "<?xml version='1.0' encoding='utf-8'?>"
'response.write "<urlset xmlns='http://www.google.com/schemas/sitemap/0.84'>"

str = "<?xml version='1.0' encoding='utf-8'?>" & vbcrlf
str = str & "<urlset xmlns='http://www.google.com/schemas/sitemap/0.84'>" & vbcrlf

set objfolder = objfso.getfolder(root)
'response.write getfilelink(objfolder.path,objfolder.datelastmodified)
set colfiles = objfolder.files
for each objfile in colfiles
'response.write getfilelink(objfile.path,objfile.datelastmodified)
str = str & getfilelink(objfile.path,objfile.datelastmodified) & vbcrlf
next
showsubfolders(objfolder)

'response.write "</urlset>"
str = str & "</urlset>" & vbcrlf
set fso = nothing

set objstream = server.createobject("adodb.stream")
with objstream
'.type = adtypetext
'.mode = admodereadwrite
.open
.charset = "utf-8"
.position = objstream.size
.writetext=str
.savetofile server.mappath("/sitemap.xml"),2 '生成的xml文件名
.close
end with

set objstream = nothing
if not err then
response.write("<script>alert('success!');history.back();</script>")
response.end
end if

sub showsubfolders(objfolder)
set colfolders = objfolder.subfolders
for each objsubfolder in colfolders
if folderpermission(objsubfolder.path) then
'response.write getfilelink(objsubfolder.path,objsubfolder.datelastmodified)
str = str & getfilelink(objsubfolder.path,objsubfolder.datelastmodified) & vbcrlf
set colfiles = objsubfolder.files
for each objfile in colfiles
'response.write getfilelink(objfile.path,objfile.datelastmodified)
str = str & getfilelink(objfile.path,objfile.datelastmodified) & vbcrlf
next
showsubfolders(objsubfolder)
end if
next
end sub


function getfilelink(file,datafile)
file=replace(file,"\","/")
file=replace(file,root,"")
if fileextensionisbad(file) then exit function
if month(datafile)<10 then filedatem="0"
if day(datafile)<10 then filedated="0"
filedate=year(datafile)&"-"&filedatem&month(datafile)&"-"&filedated&day(datafile)
getfilelink = "<url><loc>"&server.htmlencode(session("server")&file)&"</loc><lastmod>"&filedate&"</lastmod><changefreq>daily</changefreq><priority>1.0</priority></url>"
response.flush
end function


function folderpermission(pathname)
'需要过滤的目录(不列在sitemap里面)
pathexclusion=array("\da@ta78#9","\member","\admin","\dxyeditor")
folderpermission =true
for each pathexcluded in pathexclusion
if instr(ucase(pathname),ucase(pathexcluded))>0 then
folderpermission = false
exit for
end if
next
end function


function fileextensionisbad(sfilename)
dim sfileextension, bfileextensionisvalid, sfileext
'modify for your file extension (http://www.googleguide.com/file_type.html)
extensions = array("png","gif","jpg","jpeg","zip","pdf","ps","html","htm","php","wk1","wk2","wk3","wk4","wk5","wki","wks","wku","lwp","mw","xls","ppt","doc","swf","wks","wps","wdb","wri","rtf","ans","txt")
'设置列表的文件名,扩展名不在其中的话sitemap则不会收录该扩展名的文件

if len(trim(sfilename)) = 0 then
fileextensionisbad = true
exit function
end if

sfileextension = right(sfilename, len(sfilename) - instrrev(sfilename, "."))
bfileextensionisvalid = false'assume extension is bad
for each sfileext in extensions
if ucase(sfileext) = ucase(sfileextension) then
bfileextensionisvalid = true
exit for
end if
next
fileextensionisbad = not bfileextensionisvalid
end function
%>