生成googlesitemap函數asp（轉老外）

<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>

<%

Response.Charset = "utf-8"

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)

session("server")="http://7thpark.com/" '你的域名

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('成功生成站點地圖!');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,root,"")

file=replace(file,"/","/")

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")&vDir&file)&"</loc><lastmod>"&filedate&"</lastmod><changefreq>daily</changefreq><priority>1.0 </priority></url>"

Response.Flush

End Function

Function Folderpermission(pathName)

'需要過濾的目錄(不列在SiteMap裡面)

PathExclusion=Array("/temp","/_vti_cnf","_vti_pvt","_vti_log","cgi-bin","/admin","/edu")

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則不會收錄該擴展名的文件