www.gusucode.com > 全球营销软件站整站源码4月最新数据 4.0源码程序 > 801wyxqf\ask\inc\customtag.asp

    <%
'--是否禁用模板缓存（False=否，True=是）
Const DisabledCache = False
Class CustomTemplate_Cls
	Private re,varHtmlCode,strText,XMLDoc
	Private HandlErr,ErrMsg,BufferTime
	Private Sub Class_Initialize()
		On Error Resume Next
		HandlErr = False
		'自定义标签缓存时间
		BufferTime = 300
		Set XMLDoc = NewAsp.CreateXMLDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
		Set re=New RegExp
		re.IgnoreCase =True
		re.Global=True
		strText="(<newaspcustom(.[^>]*)\/>)|(<newaspcustom[^>]*?>([\w\W]*?)<\/newaspcustom>)"
	End Sub

	Private Sub Class_Terminate()
		Set XMLDoc=Nothing
		Set re=Nothing
		'Set iCustom=Nothing
	End Sub
	Public Property Let input(ByVal NewValue)
		varHtmlCode = NewValue
	End Property
	Public Property Get output()
		output = varHtmlCode
	End Property

	Public Function appendTemplate(strContent)
		Dim strMatchs,strMatch,m_strMatch,iCount
		iCount = 0
		re.Pattern=strText
		Set strMatchs=re.Execute(strContent)
		For Each strMatch in strMatchs
			m_strMatch = strMatch.Value
			If InStr(strContent,m_strMatch) > 0 Then
				iCount = iCount + 1
				strContent = Replace(strContent,m_strMatch,appendXmlNode(m_strMatch))
			End If
		Next
		appendTemplate = strContent
	End Function

	Public Function appendXmlNode(str)
		Dim Node,b
		Dim strAction,strName,strFile,strTitle,strSQL
		Dim intLength,intMaxTop,intType,strMatchData
		Dim setcache,classid,orders,intDate,rootNode
		If XMLDoc.loadxml("<xml>" & Replace(LCase(str), "&", "&amp;") &"</xml>") Then
			Set Node=XMLDoc.documentElement.selectSingleNode("newaspcustom")
			If Not Node Is Nothing Then
				strAction = NewAsp.CheckStr(Node.getAttribute("action"))
				If strAction = "" Then strAction = "0"
				strName = NewAsp.CheckStr(Node.getAttribute("name"))
				strFile = CheckFileName(Node.getAttribute("file"))
				strTitle = NewAsp.CheckStr(Node.getAttribute("title"))
				classid = NewAsp.CheckStr(Node.getAttribute("classid"))
				setcache = NewAsp.CheckStr(Node.getAttribute("setcache"))
				rootNode = NewAsp.CheckStr(Node.getAttribute("node"))
				If setcache = "" Then setcache = "0"
				If classid="" Then classid="0"
				strSQL = Node.getAttribute("sql")
				If IsNull(strSQL) Then strSQL = ""
				intLength = NewAsp.ChkNumeric(Node.getAttribute("length"))
				intMaxTop = NewAsp.ChkNumeric(Node.getAttribute("maxtop"))
				intType = NewAsp.ChkNumeric(Node.getAttribute("type"))
				orders = NewAsp.ChkNumeric(Node.getAttribute("order"))
				intDate = NewAsp.ChkNumeric(Node.getAttribute("date"))
				strMatchData = LoadXMLDocument(Node,strAction,intMaxTop,intLength,intType,strName,strTitle,classid,strSQL,strFile,setcache,orders,intDate,rootNode)
				appendXmlNode = strMatchData
				'For Each b in Node.Attributes
					'Response.Write "[" & b.Name & ":" & b.Value & "] "
				'Next
			Else
				appendXmlNode = "没有找到自定义标签错误"
			End If
			Set Node=Nothing
		Else
				appendXmlNode = "载入自定义标签错误，此标签不符合xhtml规范。"
		End If
	End Function

	Public Function LoadXMLDocument(iNode,ByVal action,ByVal maxtop,ByVal intLength,ByVal stype,ByVal strName,ByVal strTitle,ByVal classid,ByVal strSQL,ByVal strFile,ByVal setcache,ByVal orders,ByVal intDate,ByVal rootNode)
		Dim iXMLDom,Templist
		Dim Rs,SQL,b,Node
		Set iXMLDom = NewAsp.CreateXMLDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
		iXMLDom.appendChild(iXMLDom.createElement("xml"))
		'iXMLDom.documentElement.setAttribute "action",action
		'iXMLDom.documentElement.setAttribute "maxtop",maxtop
		'iXMLDom.documentElement.setAttribute "type",stype
		'iXMLDom.documentElement.setAttribute "length",intLength
		'iXMLDom.documentElement.setAttribute "name",strName
		'iXMLDom.documentElement.setAttribute "title",strTitle
		For Each b in iNode.Attributes
			iXMLDom.documentElement.setAttribute b.Name,b.Value
		Next
		Select Case strName
			Case "asked"
				Call LoadAskedList(iXMLDom,maxtop,intLength,stype,classid,setcache,orders,intDate,rootNode)
			Case "share"
				Call LoadShareList(iXMLDom,maxtop,intLength,stype,classid,setcache,orders,intDate,rootNode)
			Case "users"
				Call LoadUsersList(iXMLDom,maxtop,stype,setcache,rootNode)
			Case "sql"
				Call LoadCustomSQLlist(iXMLDom,setcache,maxtop,strSQL,rootNode)
			Case Else
				Call LoadAskedList(iXMLDom,maxtop,intLength,stype,classid,setcache,orders,intDate)
		End Select
		LoadXMLDocument = TransformXSLTemplate(iXMLDom,strFile)
		Set iXMLDom=Nothing
	End Function

	Public Function TransformXSLTemplate(iXMLDom,strFile)
		Dim proc,XMLStyle,node,cnode,XSLTemplate
		If HandlErr Then TransformXSLTemplate=ErrMsg : Exit Function
		If strFile = "" Then strFile = "xslt/default.xslt"
		Set XSLTemplate=NewAsp.CreateAXObject("Msxml2.XSLTemplate" & MsxmlVersion )
		Set XMLStyle=NewAsp.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion )
		If XMLStyle.load(Server.MapPath(NewAsp.TemplatePath & strFile)) Then
			Set Node=XMLStyle.createNode(1,"xsl:variable","http://www.w3.org/1999/XSL/Transform")
			Set CNode=XMLStyle.createNode(2,"name","")
			CNode.text="installdir"
			Node.attributes.setNamedItem(CNode)
			Node.text=NewAsp.InstallDir
			XMLStyle.documentElement.appendChild(node)
			Set Node=XMLStyle.createNode(1,"xsl:variable","http://www.w3.org/1999/XSL/Transform")
			Set CNode=XMLStyle.createNode(2,"name","")
			CNode.text="skinurl"
			Node.attributes.setNamedItem(CNode)
			Node.text=NewAsp.AskedSkinUrl
			XMLStyle.documentElement.appendChild(node)
			XSLTemplate.stylesheet=XMLStyle
			Set proc = XSLTemplate.createProcessor()
			proc.input = iXMLDom
			proc.transform()
			Dim procstr
			procstr = proc.output
			Set proc=Nothing
			TransformXSLTemplate = procstr
		Else
			TransformXSLTemplate = "载入模板错误...请检查模板文件(" & NewAsp.TemplatePath & strFile & ")是否存在或者是否符合XSLT规范"
		End If
		Set XMLStyle=Nothing
		Set XSLTemplate=Nothing
	End Function

	Public Function CheckFileName(ByVal strFile)
		If Not IsNull(strFile) And strFile<>"" Then
			strFile = Replace(strFile, Chr(0), "")
			strFile = Replace(strFile, vbCrLf, "")
			If InStr(strFile,".") > 0 Then
				CheckFileName = strFile
			Else
				CheckFileName = strFile & ".xslt"
			End If
		Else
			CheckFileName = "xslt/default.xslt"
		End If
	End Function

	Public Function xmlencode(ByVal str)
		Dim i
		str = Replace(str,"&","&amp;")
		For i = 0 to 31
			str = Replace(str,Chr(i),"&amp;#"&i&";")
		Next
		For i = 95 to 96
			str = Replace(str,Chr(i),"&amp;#"&i&";")
		Next
		xmlencode = str
	End Function

	Public Function xmldecode(ByVal str)
		Dim i
		str = Replace(str,"&amp;","&")
		For i = 0 to 31
			str = Replace(str,"&#"&i&";",Chr(i))
		Next
		For i = 95 to 96
			str = Replace(str,"&#"&i&";",Chr(i))
		Next
		xmldecode = str
	End Function

	Sub UpdateCache(sAppID,sBuff)
		Application.Lock
		Application(sAppID&"_lastime")=Now()
		Application(sAppID&"_buffer")=sBuff
		Application.UnLock
	End Sub

	Private Sub LoadCustomSQLlist(iXMLDom,ByVal setcache,ByVal maxtop,ByVal strSQL,ByVal rootNode)
		On Error Resume Next
		Dim SQL,Rs,topiclist,Node,i
		Dim sAppID
		If strSQL="" Then Exit Sub
		If rootNode = "" Or rootNode = "row" Or rootNode = "xml" Then rootNode = "topiclist"
		sAppID		= NewAsp.CacheName &"_custom_"& setcache
		If maxtop = 0 Then maxtop = 10
		If maxtop > 500 Then maxtop = 10
		If Not CacheIsObject(setcache,Application(NewAsp.CacheName & "_custom_" & setcache)) Then
			SQL=LCase(strSQL)
			Set Rs = NewAsp.Execute(SQL)
			If Err.Number <> 0 Then
				HandlErr = True
				ErrMsg = "SQL 查询错误,请检查您的SQL查询代码是否正确(" & strSQL & ")"
				Exit Sub
			End If
			Set topiclist=NewAsp.RecordsetToxml(rs,"row",rootNode)
			If EnabledCache(setcache) Then
				Application.Lock
					Set Application(NewAsp.CacheName & "_custom_" & setcache)=topiclist
				Application.unLock
			End If
			Rs.Close : Set Rs=Nothing
			SQL=Empty
		Else
			Set topiclist=Application(NewAsp.CacheName & "_custom_" & setcache)
		End If
		If Not topiclist Is Nothing Then
			i = 0
			For Each Node in topiclist.documentElement.SelectNodes("row")
				i = i + 1
				Node.attributes.setNamedItem(topiclist.createNode(2,"index","")).text = i
			Next
			iXMLDom.documentElement.appendChild(topiclist.documentElement.cloneNode(True))
		End If
		Set topiclist=Nothing
	End Sub

	Private Sub LoadAskedList(iXMLDom,ByVal maxtop,ByVal intLength,ByVal stype,ByVal classid,ByVal setcache,ByVal orders,ByVal intDate,ByVal rootNode)
		Dim SQL,Rs,topiclist,Node,FoundSQL,i
		Dim strOrder,setClass
		If orders=0 Then
			strOrder = "LastPostTime"
		Else
			strOrder = "TopicID"
		End If
		If rootNode = "" Or rootNode = "row" Or rootNode = "xml" Then rootNode = "topic"
		If maxtop = 0 Then maxtop = 10
		If maxtop > 500 Then maxtop = 10
		If classid = "0" Then
			setClass = ""
		Else
			If InStr(classid,",") = 0 Then
				setClass = " And classid=" & NewAsp.ChkNumeric(classid)
			Else
				classid = CheckIDlist(classid)
				If classid="" Then
					setClass = ""
				Else
					setClass = " And classid in (" & classid & ")"
				End If
			End If
		End If
		Select Case stype
			Case 1
				FoundSQL = " WHERE topicmode=1 And LockTopic=0" & setClass & " ORDER BY " & strOrder & " DESC"
			Case 2
				FoundSQL = " WHERE topicmode=0 And LockTopic=0" & setClass & " ORDER BY Reward DESC, " & strOrder & " DESC"
			Case 3
				FoundSQL = " WHERE topicmode<3 And LockTopic=0" & setClass & " ORDER BY Hits DESC, " & strOrder & " DESC"
			Case 4
				FoundSQL = " WHERE topicmode<3 And LockTopic=0" & setClass & " And Broadcast=1 ORDER BY " & strOrder & " DESC"
			Case 5
				FoundSQL = " WHERE topicmode<3 And LockTopic=0" & setClass & " ORDER BY PostNum DESC, " & strOrder & " DESC"
			Case 6
				FoundSQL = " WHERE topicmode<3 And LockTopic=0" & setClass & " And IsTop>0 ORDER BY " & strOrder & " DESC"
			Case Else
				FoundSQL = " WHERE topicmode=0 And LockTopic=0" & setClass & " ORDER BY TopicID DESC"
		End Select
		If Not CacheIsObject(setcache,Application(NewAsp.CacheName & "_asked_" & setcache)) Then
			SQL="SELECT Top " & maxtop & " TopicID,classid,userid,classname,title,PostUsername,DateAndTime,LastPostTime,Reward,Hits,PostNum,TopicMode,Highlight,Anonymous FROM NC_Ask_Topic " & FoundSQL
			Set Rs = NewAsp.Execute(SQL)
			Set topiclist=NewAsp.RecordsetToxml(rs,"row",rootNode)
			If EnabledCache(setcache) Then
				Application.Lock
					Set Application(NewAsp.CacheName & "_asked_" & setcache)=topiclist
				Application.unLock
			End If
			Rs.Close : Set Rs=Nothing
			SQL=Empty
		Else
			Set topiclist=Application(NewAsp.CacheName & "_asked_" & setcache)
		End If
		If Not topiclist Is Nothing Then
			i = 0
			For Each Node in topiclist.documentElement.SelectNodes("row")
				i = i + 1
				Node.attributes.setNamedItem(topiclist.createNode(2,"index","")).text = i
				If intLength > 0 Then
					Node.selectSingleNode("@title").text=Replace(NewAsp.CutStr(Node.selectSingleNode("@title").text,intLength),"<","&lt;")
				Else
					Node.selectSingleNode("@title").text=Replace(Node.selectSingleNode("@title").text,"<","&lt;")
				End If
				Node.selectSingleNode("@dateandtime").text=NewAsp.FormatDate(Node.selectSingleNode("@dateandtime").text,intDate)
				Node.selectSingleNode("@lastposttime").text=NewAsp.FormatDate(Node.selectSingleNode("@lastposttime").text,intDate)
			Next
			iXMLDom.documentElement.appendChild(topiclist.documentElement.cloneNode(True))
		End If
		Set topiclist=Nothing
	End Sub

	Private Sub LoadShareList(iXMLDom,ByVal maxtop,ByVal intLength,ByVal stype,ByVal classid,ByVal setcache,ByVal orders,ByVal intDate,ByVal rootNode)
		Dim SQL,Rs,topiclist,Node,FoundSQL,i
		Dim strOrder,setClass
		If orders=0 Then
			strOrder = "LastPostTime"
		Else
			strOrder = "TopicID"
		End If
		If rootNode = "" Or rootNode = "row" Or rootNode = "xml" Then rootNode = "topic"
		If maxtop = 0 Then maxtop = 10
		If maxtop > 500 Then maxtop = 10
		'intLength = CLng(intLength)
		If classid = "0" Then
			setClass = ""
		Else
			If InStr(classid,",") = 0 Then
				setClass = " And classid=" & NewAsp.ChkNumeric(classid)
			Else
				classid = CheckIDlist(classid)
				If classid="" Then
					setClass = ""
				Else
					setClass = " And classid in (" & classid & ")"
				End If
			End If
		End If
		Select Case stype
			Case 1
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " ORDER BY " & strOrder & " DESC"
			Case 2
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " ORDER BY Hits DESC, " & strOrder & " DESC"
			Case 3
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " And Broadcast=1 ORDER BY " & strOrder & " DESC"
			Case 4
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " ORDER BY PostNum DESC, " & strOrder & " DESC"
			Case 5
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " And IsTop>0 ORDER BY " & strOrder & " DESC"
			Case Else
				FoundSQL = " WHERE topicmode=3 And LockTopic=0" & setClass & " ORDER BY TopicID DESC"
		End Select
		If Not CacheIsObject(setcache,Application(NewAsp.CacheName & "_share_" & setcache)) Then
			SQL="SELECT Top " & maxtop & " TopicID,classid,userid,classname,title,PostUsername,DateAndTime,LastPostTime,Reward,Hits,PostNum,TopicMode,Highlight,Anonymous FROM NC_Ask_Topic " & FoundSQL
			Set Rs = NewAsp.Execute(SQL)
			Set topiclist=NewAsp.RecordsetToxml(rs,"row",rootNode)
			If EnabledCache(setcache) Then
				Application.Lock
					Set Application(NewAsp.CacheName & "_share_" & setcache)=topiclist
				Application.unLock
			End If
			Rs.Close : Set Rs=Nothing
			SQL=Empty
		Else
			Set topiclist=Application(NewAsp.CacheName & "_share_" & setcache)
		End If
		If Not topiclist Is Nothing Then
			i = 0
			For Each Node in topiclist.documentElement.SelectNodes("row")
				i = i + 1
				Node.attributes.setNamedItem(topiclist.createNode(2,"index","")).text = i
				If intLength > 0 Then
					Node.selectSingleNode("@title").text=Replace(NewAsp.CutStr(Node.selectSingleNode("@title").text,intLength),"<","&lt;")
				Else
					Node.selectSingleNode("@title").text=Replace(Node.selectSingleNode("@title").text,"<","&lt;")
				End If
				Node.selectSingleNode("@dateandtime").text=NewAsp.FormatDate(Node.selectSingleNode("@dateandtime").text,intDate)
				Node.selectSingleNode("@lastposttime").text=NewAsp.FormatDate(Node.selectSingleNode("@lastposttime").text,intDate)
			Next
			iXMLDom.documentElement.appendChild(topiclist.documentElement.cloneNode(True))
		End If
		Set topiclist=Nothing
	End Sub

	Private Sub LoadUsersList(iXMLDom,ByVal maxtop,ByVal stype,ByVal setcache,ByVal rootNode)
		Dim SQL,Rs,Userslist,Node,FoundSQL,i
		If rootNode = "" Or rootNode = "row" Or rootNode = "xml" Then rootNode = "users"
		If maxtop = 0 Then maxtop = 10
		If maxtop > 500 Then maxtop = 10
		Select Case stype
			Case 1
				FoundSQL = " WHERE Userlock=0 ORDER BY Points DESC,userid DESC"
			Case 2
				FoundSQL = " WHERE Userlock=0 ORDER BY Asktotal DESC,userid DESC"
			Case 3
				FoundSQL = " WHERE Userlock=0 ORDER BY Answertotal DESC,userid DESC"
			Case 4
				FoundSQL = " WHERE Userlock=0 ORDER BY Askoverdue DESC,userid DESC"
			Case 5
				FoundSQL = " WHERE Userlock=0 ORDER BY Askshare DESC,userid DESC"
			Case Else
				FoundSQL = " WHERE Userlock=0 ORDER BY userid DESC"
		End Select
		If Not CacheIsObject(setcache,Application(NewAsp.CacheName & "_users_" & setcache)) Then
			SQL="SELECT Top " & maxtop & " userid,Username,Nickname,Password,UserClass,Useremail,Usersex,Photo,Homepage,Points,Experience,Asktotal,Askoverdue,Answertotal FROM NC_Ask_Users " & FoundSQL
			Set Rs = NewAsp.Execute(SQL)
			Set Userslist=NewAsp.RecordsetToxml(rs,"row",rootNode)
			If EnabledCache(setcache) Then
				Application.Lock
					Set Application(NewAsp.CacheName & "_users_" & setcache)=Userslist
				Application.unLock
			End If
			Rs.Close : Set Rs=Nothing
			SQL=Empty
		Else
			Set Userslist=Application(NewAsp.CacheName & "_users_" & setcache)
		End If
		If Not Userslist Is Nothing Then
			i = 0
			For Each Node in Userslist.documentElement.SelectNodes("row")
				i = i + 1
				Node.attributes.setNamedItem(Userslist.createNode(2,"index","")).text = i
			Next
			iXMLDom.documentElement.appendChild(Userslist.documentElement.cloneNode(True))
		End If
		Set Userslist=Nothing
	End Sub

	Private Function CacheIsObject(isCache,CacheObj)
		CacheIsObject = False
		Dim dLastime,sAppID
		If DisabledCache Then Exit Function
		If isCache = "0" Then Exit Function
		If isCache = "-1" Then Exit Function
		If isCache = "no" Then Exit Function
		sAppID = NewAsp.CacheName &"_custom_"& isCache
		dLastime = Application(sAppID&"_lastime")
		If IsObject(CacheObj) And ""<>dLastime And _
			DateDiff("s", CDate(dLastime), Now()) <= CLng(BufferTime) Then
			CacheIsObject = True
		Else
			Application.Lock
			Application(sAppID&"_lastime")=Now()
			Application.UnLock
			CacheIsObject = False
		End If
	End Function

	Private Function EnabledCache(isCache)
		EnabledCache = False
		If DisabledCache Then Exit Function
		If isCache = "0" Then Exit Function
		If isCache = "-1" Then Exit Function
		If isCache = "no" Then Exit Function
		EnabledCache = True
	End Function
	Public Function CheckIDlist(ByVal strList)
		On Error Resume Next
		If Not IsNull(strList) And strList<>"" And strList<>"0" Then
			Dim strArray,i,n,m_strID,CHECK_ID
			Dim TempIDlist()
			strArray=Split(strList, ",")
			n=0
			m_strID = ","
			For i=0 To UBound(strArray)
				CHECK_ID = Trim(strArray(i))
				If CHECK_ID<>"" And IsNumeric(CHECK_ID) And CHECK_ID<>"0" Then
					If InStr(m_strID,","& CHECK_ID &",") = 0 Then
						ReDim Preserve TempIDlist(n)
						TempIDlist(n) = CHECK_ID
						n=n+1
					End If
					m_strID = m_strID & CHECK_ID &","
				End If
			Next
			CheckIDlist=Join(TempIDlist, ",")
		Else
			CheckIDlist=""
		End If
	End Function
End Class
%>