asp生成sitemap.xml(站点地图)文件的代码

Google提供的那个Sitemap 生成器，我实在弄不来，有个在线生成sitemap.xml的网站不错，地址是https://www.360docs.net/doc/04803931.html,/default.aspx，不过更新起来太麻烦了，于是上网找来一段asp的代码。

只需修改代码中的域名，生成目录，例外文件夹、扩展名及单独的例外文件即可（代码中的红色部分）。

<%@ CODEPAGE=65001 %>
<% Response.CharSet="UTF-8" %>
<% Response.Buffer=True %>
<%
' For https://www.360docs.net/doc/04803931.html, sitemaps xml

Server.ScriptTimeout = 50000
session("server") = "https://www.360docs.net/doc/04803931.html," '域名
vDir = "/"'制作SiteMap的目录,相对根目录 全站为"/"

Set objfso = CreateObject("Scripting.FileSystemObject")
root = Server.MapPath(vDir)'"D:\askmyself"'Server.MapPath(vDir)
str = "" & vbcrlf
str = str & "" & vbcrlf
str = str & "" & vbcrlf

Set objFolder = objFSO.GetFolder(root)
Set colFiles = objFolder.Files
For Each objFile In colFiles
str = str & getfilelink(objFile.Path,objfile.dateLastmodified) & vbcrlf
Next
ShowSubFolders(objFolder)

str = str & "" & vbcrlf
Set fso = Nothing

Set objStream = Server.CreateObject("ADODB.Stream")
With objStream
.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("")
Response.End
End If

Sub ShowSubFolders(objFolder)
Set colFolders = objFolder.SubFolders
For Each objSubFolder In colFolders
If Folderpermission(objSubFolder.Path) Then
str = str & getfilelink(objSubFolder.Path,objSubFolder.dateLastmodified) & vbcrlf
Set colFiles = objSubFolder.Files
For Each objFile In colFiles
str = str & getfilelink(objFile.Path,objFile.dateLastmodified) & vbcrlf
Next
ShowSubFolders(objSubFolder)
End If
Next
End Sub

Function getfilelink(File,datafile)
File = Replace(File,root,"",1,-1,1)
File = Replace(File,"\","/")
If FileExtensionIsBad(File) Then Exit Function
nfile = Session("server") & vDir & File
nfile = "http://" & Replace(nfile,"//","/") '替换根目录链接的双斜杠
If Month(datafile) < 10 Then filedatem = "0"
If Day(datafile) < 10 Then filedated = "0"
filedate = Year(datafile) & "-" & filedatem & Month(datafile) & "-" & filedated & Day(datafile)
getfilelink = "" & vbcrlf
getfilelink = getfilelink & " " & Server.HtmlEncode(nfile) & "" & vbcrlf
getfilelink = getfilelink & " " & filedate & "" & vbcrlf
getfilelink = getfilelink & " daily " & vbcrlf
getfilelink = getfilelink & " 1.0" & vbcrlf
getfileli

nk = getfilelink & "" & vbcrlf '& root
Response.Flush
End Function


Function Folderpermission(pathName) '需要过滤的目录(不列在SiteMap里面)
PathExclusion = Array("\ADMIN","\CACHE","\cert","\CSS","\DATA","\FUNCTION","\IMAGE","\INCLUDE","\LANGUAGE","\PLUGIN","\SCRIPT","\THEMES","\UPLOAD","\XML-RPC")
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, sPass
Extensions = Array("html","htm") '设置列表的文件名,扩展名不在其中的话SiteMap则不会收录该扩展名的文件
PassFileNames = Array("default.asp","guestbook.asp","tags.asp","search.asp","catalog.asp") '设置例外，其他扩展名的少数文件
If Len(Trim(sFileName)) = 0 Then
FileExtensionIsBad = True
Exit Function
End If

sFileExtension = Right(sFileName, Len(sFileName) - Instrrev(sFileName, "."))
bFileExtensionIsValid = False
For Each sFileExt In Extensions
If UCase(sFileExt) = UCase(sFileExtension) Then
bFileExtensionIsValid = true
Exit For
Else
For Each sPass In PassFileNames
If Instr(UCase(sFileName),UCase(sPass)) > 0 Then
bFileExtensionIsValid = True
Exit For
Else
bFileExtensionIsValid = False
End If
Next
End If
Next
FileExtensionIsBad = Not bFileExtensionIsValid
End Function
%>