这是一个完整的ASP生成SITEMAP程序,只要将该程序放在站点目录任何一个位置调动一下即可在站点根目录生成sitemap.xml文件。程序生成的SITEMAP.XML会自动根据目录的深度递减priority（优先级）值

<%
flag=Trim(Request("flag"))
If flag="BUILD" Then
 response.write "SITEMAP生成程序,作者:晶友软件,网站:www.cfsoft.com.cn" & "<br>"
 Server.ScriptTimeout=500000
 'on error resume next

 session("server")= "http://"&Trim(Request.ServerVariables("SERVER_NAME"))'
 vDir = "/" '制作SiteMap的目录,相对目录(相对于根目录而言)
 set objfso = CreateObject("Scripting.FileSystemObject")
 root = Server.MapPath(vDir)

 str = "<?xml version=""1.0"" encoding=""UTF-8""?>"
 str = str & "<urlset xmlns=""http://www.sitemaps.org/schemas/sitemap/0.9"">" & vbcrlf

 Set objFolder = objFSO.GetFolder(root)

 Set colFiles = objFolder.Files

 For Each objFile In colFiles
  str = str & getfilelink(objFile.Path,objfile.dateLastModified,1.0)
 Next
 Call ShowSubFolders(objFolder,0.9)
 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('...............成功生成站点地图..................');</script>")
  Response.End
 End If

 Sub ShowSubFolders(objFolder,priority)
  Dim temppriority
  Set colFolders = objFolder.SubFolders
  For Each objSubFolder In colFolders
   if folderpermission(objSubFolder.Path) then
    str = str & getfilelink(objSubFolder.Path,objSubFolder.dateLastModified,priority)
    Set colFiles = objSubFolder.Files
    For Each objFile In colFiles
     str = str & getfilelink(objFile.Path,objFile.dateLastModified,priority)
    Next
    If priority>0.5 Then
     temppriority=priority-0.1
    Else
     temppriority=0.5
    End if
    Call ShowSubFolders(objSubFolder,temppriority)
   end if
  Next
 End Sub

 Function getfilelink(file,datafile,priority)
  Dim temppriority
  If priority=1.0 Then
   temppriority=priority&".0"
  End If
  If Left(CStr(priority),1)="." Then
   temppriority="0"&priority
  End if
  root=replace(root,"\","/")
  root=LCase(root)
  file=replace(file,"\","/")
  file=LCase(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>"&vbcrlf
   getfilelink=getfilelink&"    <loc>"&server.htmlencode(session("server")&file)&"</loc>"&vbcrlf
   getfilelink=getfilelink&"    <lastmod>"&filedate&"</lastmod>"&vbcrlf
   getfilelink=getfilelink&"    <changefreq>daily</changefreq>"&vbcrlf
   getfilelink=getfilelink&"    <priority>"&temppriority&"</priority>"&vbcrlf
   getfilelink=getfilelink&"  </url>"&vbcrlf
   response.write "成功生成地址："& server.htmlencode(session("server")&file) & "<br>"

   Response.Flush
 End Function

 Function Folderpermission(pathName)

  '需要过滤的目录(不列在SiteMap里面)
  PathExclusion=Array("\admin","\_vti_cnf","_vti_pvt","_vti_log","cgi-bin","\bizadmin","\bookpic","\css","\data","\eWebEditor","\footprint","\images","\images_remote","\Inc","\js","\myimg","\netfootimg","\netheadimg","\netimg","\picture","\css","\conn""\Skin","\skin_Mesky","\uploadfile","\uploadfiles","\uploadpic")
  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 Extension, bFileExtensionIsValid, sFileExt
  Extensions = Array("html","htm")
  '设置列表的文件名,扩展名不在其中的话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
End if
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link href="images/css.css" rel="stylesheet" type="text/css">
<title>SITEMAP生成-晶友软件http://www.cfsoft.com.cn</title>
</head>

<body>

<br>
<br>
<br>
<br>
<br>
<form action="sitemap.asp?flag=BUILD" method="post" name="fm1" id="fm1">
  <table width="99%" border="0" align="center" class="tableBorder">
    <tr bgcolor="#E8F1FF">
      <td colspan="6" align="center"  class="td">
          <input type="submit" name="Submit" value="生成">
        </td>
    </tr>
 
  </table>
  <br>

</form>

</body>
</html>

评论 (0) All

登陆 还没注册？