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"）="http://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
%>