google sitemap.asp

<% 
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")="https://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 
%>