用于生成sitemap.xml文件的东西，利于google等搜索引擎的抓取。
复制代码 代码如下:
<%
Server.ScriptTimeout=50000
'sitemap_gen.asp
'Asimplescripttoautomaticallyproducesitemapsforawebserver,intheGoogleSitemapProtocol(GSP)
'byFrancescoPassantino
'www.iteam5.net/francesco/sitemap
'v0.2released5june2005(Listingadirectorytreerecursivelyimprovement)
'
'BSD2.0license,
'http://www.opensource.org/licenses/bsd-license.php
'收集整理:重庆森林@im286.com
session("server")="http://www.jb51.net"
'你的域名
vDir="/"
'制作SiteMap的目录,相对目录(相对于根目录而言)
setobjfso=CreateObject("Scripting.FileSystemObject")
root=Server.MapPath(vDir)
'response.ContentType="text/xml"
'response.write"<?xmlversion='1.0'encoding='UTF-8'?>"
'response.write"<urlsetxmlns='http://www.google.com/schemas/sitemap/0.84'>"
str="<?xmlversion='1.0'encoding='UTF-8'?>"&vbcrlf
str=str&"<urlsetxmlns='http://www.google.com/schemas/sitemap/0.84'>"&vbcrlf
SetobjFolder=objFSO.GetFolder(root)
'response.writegetfilelink(objFolder.Path,objFolder.dateLastModified)
SetcolFiles=objFolder.Files
ForEachobjFileIncolFiles
'response.writegetfilelink(objFile.Path,objfile.dateLastModified)
str=str&getfilelink(objFile.Path,objfile.dateLastModified)&vbcrlf
Next
ShowSubFolders(objFolder)
'response.write"</urlset>"
str=str&"</urlset>"&vbcrlf
setfso=nothing
SetobjStream=Server.CreateObject("ADODB.Stream")
WithobjStream
'.Type=adTypeText
'.Mode=adModeReadWrite
.Open
.Charset="utf-8"
.Position=objStream.Size
.WriteText=str
.SaveToFileserver.mappath("/sitemap.xml"),2'生成的XML文件名
.Close
EndWith
SetobjStream=Nothing
IfNotErrThen
Response.Write("<script>alert('success!');history.back();</script>")
Response.End
EndIf
SubShowSubFolders(objFolder)
SetcolFolders=objFolder.SubFolders
ForEachobjSubFolderIncolFolders
iffolderpermission(objSubFolder.Path)then
'response.writegetfilelink(objSubFolder.Path,objSubFolder.dateLastModified)
str=str&getfilelink(objSubFolder.Path,objSubFolder.dateLastModified)&vbcrlf
SetcolFiles=objSubFolder.Files
ForEachobjFileIncolFiles
'response.writegetfilelink(objFile.Path,objFile.dateLastModified)
str=str&getfilelink(objFile.Path,objFile.dateLastModified)&vbcrlf
Next
ShowSubFolders(objSubFolder)
endif
Next
EndSub
Functiongetfilelink(file,datafile)
file=replace(file,"","/")
file=replace(file,root,"")
IfFileExtensionIsBad(file)thenExitFunction
ifmonth(datafile)<10thenfiledatem="0"
ifday(datafile)<10thenfiledated="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
EndFunction
FunctionFolderpermission(pathName)
'需要过滤的目录(不列在SiteMap里面)
PathExclusion=Array("da@ta78#9","member","admin","dxyeditor")
Folderpermission=True
foreachPathExcludedinPathExclusion
ifinstr(ucase(pathName),ucase(PathExcluded))>0then
Folderpermission=False
exitfor
endif
next
EndFunction
FunctionFileExtensionIsBad(sFileName)
DimsFileExtension,bFileExtensionIsValid,sFileExt
'modifyforyourfileextension(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则不会收录该扩展名的文件
iflen(trim(sFileName))=0then
FileExtensionIsBad=true
ExitFunction
endif
sFileExtension=right(sFileName,len(sFileName)-instrrev(sFileName,"."))
bFileExtensionIsValid=false'assumeextensionisbad
foreachsFileExtinextensions
ifucase(sFileExt)=ucase(sFileExtension)then
bFileExtensionIsValid=True
exitfor
endif
next
FileExtensionIsBad=notbFileExtensionIsValid
EndFunction
%>