用ASP实现SITEMAP生成程序－站长资讯网info110.com

这是一个完整的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>

</form>

</body>
</html>

上一篇:实现通过XMLHTTP生成模板式静态页的代码
下一篇:编写获取数据库中所有表名和字段名的asp代码

TAG: ASP SITEMAP

搜索

用ASP实现SITEMAP生成程序