Google sitemap. asp

It is used to generate sitemap. xml files, facilitating crawling by google and other search engines. Copy codeThe Code is as follows: <%
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
& Apos; v0.2 released 5 June 2005 (Listing a directory tree recursively improvement)
'
'Bsd 2.0 license,
'Http://www.opensource.org/licenses/bsd-license.php
'Collect and organize: Chongqing forest @ im286.com
Session ("server") = "http://www.jb51.net"
'Your Domain Name
VDir = "/"
'Create the SiteMap directory, relative directory (relative to the root directory)
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' generated XML file name
. Close
End

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.html encode (session ("server") & file) & "</loc> <lastmod>" & filedate & "</lastmod> <changefreq> daily </changefreq> <priority> 1.0 </priority> </url>"
Response. Flush
End Function

Function Folderpermission (pathName)
'Directory to be filtered (not listed in 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
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 ")
'Specifies The Name Of The list file. If the extension is not in the list, SiteMap will not include the file with this extension.

If len (trim (sFileName) = 0 then
FileExtensionIsBad = true
Exit Function
End if

SFileExtension = right (sFileName, len (sFileName)-limit Rev (sFileName ,"."))
BFileExtensionIsValid = false 'assume extension is bad
For each sFileExt in extensions
If ucase (sFileExt) = ucase (sFileExtension) then
BFileExtensionIsValid = True
Exit
End if
Next
FileExtensionIsBad = not bFileExtensionIsValid
End Function
%>