Asp生成sitemap(站点地图)类__自定义函数_后台技术函数|sitemap|google站点地图飞飞Asp技术乐园

Asp生成sitemap(站点地图)类

时间： 2007-12-19 11:59:22　阅读次数：4536

Asp生成站点地图类
函数|sitemap|google站点地图

'Option Explicit
Class SiteMap
Private FileStr,LinkStr,Otherstr
Private Str,Er,Url,Dir,Root,AllowExtension,i,FolderPath,CountPerPage,PageName,Page,Other
Private Conn,Sql,Link
Private AllMsg
'Asp生成站点地图类(生成xml文件)（google站点地图）
'------------------声明------------------
'作者：飞飞
'网站: www.ffasp.com
'Q Q: 276230416
'注:欢迎讨论交流
' 您可以更改和使用本程序，但请保留作者和出处
'----------------------------------------
'****************************************
'----------------------------------------
'-----------------程序介绍---------------
'最近一直招关于站点地图的一些资料，翻了几遍百度和google后
'发现生成站点地图的工具的确比较多，但是易用性以及生成的效率和速度的确不怎么让人满意
'关于Asp生成站点地图的函数也不是很多且易用性不是很强
'所以自己写了这个 asp生成站点地图类尽量的做到易用、方便、快捷相对较高的质量
'特在此分享给大家使用如果在使用方面有什么不周之处或更好的方案欢迎与大家交流
'****简介：****
'此类支持两种生成方式，但至少要选择一种（生成xml文件）
'1.按照指定目录指定文件类型生成站点地图
'2.按照指定数据库（sql语句）、指定链接生成站点地图
'3.生成的sitemap.xml位于网站的根目录
'---------------程序参数说明-------------
'***[输入参数]公共参数<全部为可选>***
'SetUrl 设置xml文件中链接所使用的域名默认值: 当前页面所在站点的域名(支持端口号访问)
'SetCountPerPage 设置生成的每个xml文件所包含的链接数目默认值: 50000
'SetOther 设置其他非扫描页面，多个页面请用"|"分割
'----------------------------------------
'***[输入参数]设置根据目录生成的参数<可选>
'SetDir 设置需要访问的目录默认值: 当前页面所在站点的根目录
'SetForbidFolderPath 设置禁止访问的子目录默认值：admin|images|img|css|style|config （若不禁止目录,可设置为空）
'SetExtension 设置允许访问的文件扩展名默认值: htm|html
'----------------------------------------
'***[输入参数]设置指定数据库（sql语句）、指定链接生成的参数<必选>
'SetConn 设置打开数据库对象
'SetSql 设置Sql语句
'SetLink 设置动态页面的链接地址
'----------------------------------------
'***[输出参数]***
'ShowSiteMapFile 若按照指定目录指定文件类型生成站点地图请使用该输出参数
'ShowSiteMapLink 若按照指定数据库（sql语句）、指定链接生成站点地图请使用该输出参数
'=====================================
'====注意事项:输入参数必须在输出参数之前；输出参数可不按上下顺序,但建议先输出动态页，后输出指定目录=====
'=================================
'**********************************************
'**********************************************
'使用实例：
'Dim NewSiteMap
'Set NewSiteMap=New SiteMap
' NewSiteMap.SetUrl="http://www.ffasp.com" '设置链接中的域名（可省略）
' NewSiteMap.SetCountPerPage=5 '设置每个xml文件的链接数目（可省略）
' NewSiteMap.SetDir="/test" '设置需要生成站点地图的目录（可省略）
' NewSiteMap.SetExtension="html|htm|asp" '设置指定目录中可访问的文件扩展名（可省略）
' NewSiteMap.SetForbidFolderPath="admin" '设置指定目录中需要屏蔽的目录（可省略）
' Set NewSiteMap.SetConn=Conn '设置打开指定数据库的 Connection对象
' NewSiteMap.SetSql="Select top 11 id,time from news" '设置 Sql语句
' NewSiteMap.SetLink="content.asp?newsid=" '设置动态页的链接
' NewSiteMap.SetOther="index.asp|index.htm" '设置动态页的链接
' NewSiteMap.ShowSiteMapLink '输出指定数据库的站点地图文件
' NewSiteMap.ShowSiteMapFile '输出指定目录的站点地图文件
'Set NewSiteMap=Nothing

Private Sub Class_initialize()
Dim FsoStream,UrlPort
Er=false
FsoStream=""
Str=""
LinkStr=""
FileStr=""
Server.ScriptTimeout=60*60 '分钟数
If Not IsObjInstalled("Scripting.FileSystemObject") Then FsoStream=FsoStream&"<Li>您的空间不支持FSO!<br />"
If Not IsObjInstalled("ADODB.Stream") Then FsoStream=FsoStream&"<Li>您的空间不支持Stream!<br />"
If FsoStream<>"" Then Er=true:Errmsg=FsoStream
Url="http://"&Request.ServerVariables("SERVER_NAME")
UrlPort=Request.ServerVariables("SERVER_PORT")
If isnumeric(UrlPort) Then
If UrlPort<>80 then Url=Url&":"&UrlPort
End If
Dir="/"
Root=Server.MapPath(Dir)
AllowExtension="htm|html"
FolderPath="admin|images|img|css|style|config"
i=1
CountPerPage=50000
PageName="sitemap"
Page=1
OtherStr=""
AllMsg=""
End Sub
private Sub Class_terminate()
If (i-1) mod countperpage<>0 Then Call ShowSiteMap(Linkstr&Filestr)
Response.Clear()
Call Showmsg(AllMsg&"数据生成完毕^_^<br />共"&page-1&"页，"&i&"条链接")
End Sub
'错误信息显示
Public Property Let Errmsg(msg)
If Er then
Response.Clear()
Call Showmsg(msg)
Response.End()
End If
End Property
'指定网址属性/输入参数
Public Property Let SetUrl(Url_)
Url=Url_
If right(Url,1)="/" Then Url=left(Url,len(Url)-1)
If instr(lcase(url),"http://")=0 Then Url="http://"&Url
End Property
'指定目录/输入参数
Public Property Let SetDir(Dir_)
Dim Fso
Dir=Replace(Dir_,"\","/")
If Dir="" Then
Dir="/"
Else
If left(Dir,1) <>"/" Then Dir="/"&Dir
End If
Root=Server.MapPath(Dir)
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Not Fso.FolderExists(Root) Then Er=true:Errmsg="您指定的目录不存在!!!"
Set FSO=Nothing
End Property
'指定允许扫描的文件扩展名
Public Property Let SetExtension(AllowExtension_)
AllowExtension=AllowExtension_
If AllowExtension="" Then AllowExtension="htm|html"
If AllowExtension<>"" Then
If left(AllowExtension,1)="|" Then AllowExtension=mid(AllowExtension,2)
If right(AllowExtension,1)="|" Then AllowExtension=left(AllowExtension,len(AllowExtension)-1)
End If
End Property
'指定不允许访问的目录
Public Property Let SetForbidFolderPath(FolderPath_)
FolderPath=FolderPath_
If FolderPath="" Then FolderPath="admin|images|img|css|style|config"
If FolderPath<>"" Then
If left(FolderPath,1)="|" Then FolderPath=mid(FolderPath,2)
If right(FolderPath,1)="|" Then FolderPath=left(FolderPath,len(FolderPath)-1)
End If
End Property
'指定每页链接数量
Public Property Let SetCountPerPage(CountPerPage_)
CountPerPage=CountPerPage_
If CountPerPage="" or not isnumeric(CountPerPage) Then
CountPerPage=50000
Else
CountPerPage=fix(abs(CountPerPage))
End If
End Property
'指定其他页面
Public Property Let SetOther(Other_)
Dim ArrayOther,EOther,Fso,TheFilePath
Other=Other_
Other=Replace(Other,"||","")
If left(Other,1)="|" Then Other=mid(Other,2)
If right(Other,1)="|" Then Other=left(Other,len(Other)-1)
Other=Replace(Other,"\","/")
ArrayOther=split(Other,"|")
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
For Each EOther in ArrayOther
If left(EOther,1) ="/" Then EOther=mid(EOther,2)
If Dir="/" Then TheFilePath=Dir&EOther Else TheFilePath=Dir&"/"&EOther
If Fso.FileExists(Server.MapPath(TheFilePath)) Then
Filestr=Filestr&GetFileLink(TheFilePath,now(),0)&vbcrlf
If i mod countperpage=0 Then Call ShowSiteMap(Filestr):Filestr=""
i=i+1
Else
AllMsg=AllMsg&"指定文件"&EOther&"不存在!!<br />"
Response.Clear()
Call Showmsg(AllMsg)
End If
Next
Set Fso=Nothing
End Property
'头文件
Public Sub SiteMapHead()
str = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbcrlf
str = str & "<urlset xmlns=""http://www.google.com/schemas/sitemap/0.84"">" & vbcrlf
End Sub
'尾文件
Public Sub SiteMapBottom()
str = str & "</urlset>"
End Sub
'显示所有文件地址
Public Sub ShowSiteMapFile()
Dim ObjFso,ObjFolder,ColFiles,ObjFile
If Linkstr<>"" Then Filestr=Filestr&Linkstr : Linkstr=""
Set ObjFso = CreateObject("Scripting.FileSystemObject")
Set ObjFolder = ObjFso.GetFolder(Root)
Set ColFiles = ObjFolder.Files
For Each ObjFile In ColFiles
If GetFileLink(ObjFile.Path,ObjFile.dateLastModified,1)<>true Then
Filestr = Filestr & GetFileLink(ObjFile.Path,ObjFile.dateLastModified,1) & vbcrlf
If i mod countperpage=0 Then Call ShowSiteMap(Filestr):Filestr=""
i=i+1
End If
Next
ShowSubFolders(objFolder)
End Sub
'生成sitemap.xml文件
Public Sub ShowSiteMap(strlink)
Dim ObjStream,MainStr
If page=1 Then page=""
MainStr=strlink
Call SiteMapHead()
str=str&MainStr
Call SiteMapBottom()
Set ObjStream = Server.CreateObject("ADODB.Stream")
With ObjStream
.Type = 2
.Mode = 3
.Open
.Charset = "utf-8"
.WriteText=str
.SaveToFile server.mappath("/"&PageName&Page&".xml"),2 '生成的XML文件名
.Close
End With
Set ObjStream = Nothing
AllMsg=AllMsg&("<li><a href=""/"&PageName&Page&".xml"" target=_blank >"&PageName&Page&".xml</a>已生成<br />")
Call Showmsg(AllMsg)
If Page="" Then Page=1
Page=Page+1
End Sub
'得到页面的链接地址
Public Function GetFileLink(FilePath,FileDate,IsExtension)
Dim FileDateShow,filedatem,filedated
FilePath=replace(FilePath,root,"")
FilePath=replace(FilePath,"\","/")
If FileExtensionIsBad(FilePath) and IsExtension=1 then GetFileLink=true: Exit Function
if month(FileDate)<10 then filedatem="0"
if day(FileDate)<10 then filedated="0"
FileDateShow=year(FileDate)&"-"&filedatem&month(FileDate)&"-"&filedated&day(FileDate)
If Dir="/" Then Dir=""
GetFileLink = "<url>"
GetFileLink=GetFileLink&"<loc>"
GetFileLink=GetFileLink&Url&Dir&FilePath
GetFileLink=GetFileLink&"</loc>"
GetFileLink=GetFileLink&"<lastmod>"
GetFileLink=GetFileLink&filedate
GetFileLink=GetFileLink&"</lastmod><changefreq>daily</changefreq><priority>1.0</priority></url>"
End Function
'检测文件的扩展名
Public Function FileExtensionIsBad(FilePath)
Dim FileExtension
FileExtensionIsBad=false
FileExtension=Split(FilePath,".")(Ubound(Split(FilePath,".")))
If FileExtension="" or isnull(FileExtension) or isempty(FileExtension) Then FileExtensionIsBad=true:Exit Function
If instr("|"&lcase(AllowExtension)&"|","|"&lcase(FileExtension)&"|")=0 Then FileExtensionIsBad=true
End Function
'检测子文件夹
Public Sub ShowSubFolders(ObjFolder)
Dim ColFolders,ObjSubFolder,ColFiles,ObjFile
Set ColFolders = ObjFolder.SubFolders
For Each ObjSubFolder In ColFolders
if FolderPermission(ObjSubFolder.Path) then
Set ColFiles = ObjSubFolder.Files
For Each ObjFile In ColFiles
If GetFileLink(ObjFile.Path,ObjFile.dateLastModified,1)<>true Then
Filestr = Filestr & GetFileLink(ObjFile.Path,ObjFile.dateLastModified,1) & vbcrlf
If i mod countperpage=0 Then Call ShowSiteMap(Filestr):Filestr=""
i=i+1
End If
Next
end if
Next
End Sub
'需要过滤的目录(不列在SiteMap里面)
Public Function FolderPermission(SubFolderPath)
Folderpermission =True
SubFolderPath=Replace(SubFolderPath,Root,"")
SubFolderPath=mid(SubFolderPath,2)
If instr("|"&lcase(FolderPath)&"|","|"&lcase(SubFolderPath)&"|")>0 Then Folderpermission=false
End Function
'===================================================================================
Public Property Set SetConn(Conn_)
If TypeName(Conn_)="Connection" Then
Set Conn=Conn_
Else
Er=true
Errmsg="数据库连接错误!!"
Exit property
End If
End Property
'指定Sql语句
Public Property Let SetSql(sql_)
Sql=Sql_
If Sql="" Then Er=true:Errmsg="您没有指定Sql语句!!"
End Property
'指定动态页面的链接
Public Property Let SetLink(Link_)
Link=trim(Link_)
Link=Replace(Link,"\","/")
If left(Link,1)="/" Then Link=mid(Link,2)
If instr(Lcase(Link),"http://")=0 Then Link=Url&"/"&Link
If right(Link,1)<>"=" then Link=Link&"="
End Property
'显示所有动态链接地址
Public Sub ShowSiteMapLink
On Error resume next
Dim Rs,j
Dim FileDateShow,filedatem,filedated,FileDate
If TypeName(Conn)<>"Connection" Then Er=true:Errmsg="数据库连接出错!!"
If Sql="" Then Er=true :Errmsg="请指定Sql语句!!"
If Link="" Then Er=true:Errmsg="连接地址有误!!"
Set Rs=Server.CreateObject("ADODB.RecordSet")
Rs.Open Sql,Conn,1,1
If Err Then Err.Clear:Rs.Close:Er=true:Errmsg="Sql语句有误!!<br />至少一个参数没有被指定值!!"
If Rs.Eof Then
Rs.Close
Er=true:Errmsg="指定的Sql中没有数据!!"
Else
If FileStr<>"" Then Linkstr=Linkstr&FileStr:FileStr=""
For j=1 to Rs.RecordCount
If Err Then Err.Clear:Rs.Close:Er=true:Errmsg="Sql语句有误!!<br />最少指定两个参数【新闻Id和新闻添加时间】!!"
FileDate=Rs(1)
If Not isdate(FileDate) Then Rs.Close:Er=true:Errmsg="Sql语句的第二个参数是非时间格式，如果使用当前时间:Access请使用now(),Sql请使用getdate()"
If month(FileDate)<10 Then filedatem="0"
If day(FileDate)<10 Then filedated="0"
FileDateShow=year(FileDate)&"-"&filedatem&month(FileDate)&"-"&filedated&day(FileDate)
Linkstr=Linkstr& "<url>"
Linkstr=Linkstr&"<loc>"
Linkstr=Linkstr&Link&Rs(0)
Linkstr=Linkstr&"</loc>"
Linkstr=Linkstr&"<lastmod>"
Linkstr=Linkstr&filedate
Linkstr=Linkstr&"</lastmod><changefreq>daily</changefreq><priority>1.0</priority></url>" &vbcrlf
If i mod countperpage=0 Then Call ShowSiteMap(Linkstr):Linkstr=""
i=i+1
Rs.MoveNext
Next
Rs.Close
Set Rs=Nothing
End If

End Sub
'判断组件是否安装函数
Public Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
Sub Showmsg(msg)
%>
<html>
<head>
<meta http-equiv="Content-Type" c />
<title>飞飞Asp乐园友情提示|www.ffasp.com</title>
<style type="text/css">
body{background-color:#426EB4}
body,table,td{font-size:12px}
a{text-decoration:none}
a:hover{text-decoration:underline; color:#FFFFFF}
</style>
<body>
<div style="margin-top:100px">
<table width="500" border="0" align="center" cellpadding="0" cellspacing="0" class="kuang">
<tr>
<td bgcolor="#999999"><img src="images/4.gif" width="7" height="4" /></td>
</tr>
<tr>
<td align="center"><table width="100%" border="0" cellspacing="0" cellpadding="0" height="150">
<tr>
<td width="16%" align="center" bgcolor="#F1F1F1"><span style="writing-mode:tb-rl;font-size:16px; letter-spacing:7px; height:100px;color:red"> 友情提示 <span style="font-family:wingdings;writing-mode:lr-tb;font-size:30px;color:green">J</span> </span> </td>
<td width="84%" align="center" bgcolor="#F1F1F1" style="font-size:14px;color:red;line-height:30px"><%=msg%><br /><a href="sitemap.htm">返回</a></td>
</tr>
</table></td>
</tr>
<tr>
<td height="47" bgcolor="#999999" style="color:#FFFFFF;font-size:12px"><a href="http://www.ffasp.com/" target="_blank"><span style="color:#FFFFFF">www.ffasp.com<br />飞飞Asp乐园</span></a></td>
</tr>
</table>
</div>
</body>
</html>
<%
End Sub
End Class
%>