⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 cl_function_public.asp

📁 淘客网上商店网站程序 淘客网上商店网站程序 淘客网上商店网站程序
💻 ASP
📖 第 1 页 / 共 4 页
字号:
🔍
1234 

'滚动显示友情链接站点
Function RollFriendLink()
	Dim sTemp
	sTemp="<script type=""text/javascript"">" & vbcrlf
	sTemp=sTemp & "<!--" & vbcrlf
	sTemp=sTemp & "var rollspeed=30" & vbcrlf
	sTemp=sTemp & "rolllink2.innerHTML=rolllink1.innerHTML //克隆rolllink1为rolllink2" & vbcrlf
	sTemp=sTemp & "function Marquee(){" & vbcrlf
	sTemp=sTemp & "if(rolllink2.offsetTop-rolllink.scrollTop<=0) //当滚动至rolllink1与rolllink2交界时" & vbcrlf
	sTemp=sTemp & "rolllink.scrollTop-=rolllink1.offsetHeight  //rolllink跳到最顶端" & vbcrlf
	sTemp=sTemp & "else{" & vbcrlf
	sTemp=sTemp & "rolllink.scrollTop++" & vbcrlf
	sTemp=sTemp & "}" & vbcrlf
	sTemp=sTemp & "}" & vbcrlf
	sTemp=sTemp & "var MyMar=setInterval(Marquee,rollspeed) //设置定时器" & vbcrlf
	sTemp=sTemp & "rolllink.onmouseover=function() {clearInterval(MyMar)}//鼠标移上时清除定时器达到滚动停止的目的" & vbcrlf
	sTemp=sTemp & "rolllink.onmouseout=function() {MyMar=setInterval(Marquee,rollspeed)}//鼠标移开时重设定时器" & vbcrlf
	sTemp=sTemp & "//-->" & vbcrlf
	sTemp=sTemp & "</script>"
	RollFriendLink=sTemp
End Function
'=========================================================
'ShowTopUser(TopNum,ShowType,OrderType)
'显示用户排行:显示数量，排列方式（1文章数，其它为注册时间）
'TopNum			----- 最多显示多少个
'ShowType		----- 排列方式
'				----- 0(用户ID)
'				----- 1(资料)
'				----- 2(金钱)
'				----- 3(点数)
'				----- 4(登录次数)
'				----- 5(等级)
'				----- 6(新增用户)   
'OrderType		----- 排序方式（0,降序，其他升序）
'=========================================================
Function ShowTopUser(Byval TopNum,Byval ShowType,Byval OrderType)
	TopNum		= Cl.GetClng(TopNum)
	ShowType	= Cl.GetClng(ShowType)
	OrderType	= Cl.GetClng(OrderType)
	If TopNum = 0 then TopNum = 10
	if OrderType=0 then
		OrderType="Desc"
	Else
		OrderType="Asc"
	End if
	Dim sqlTop,rsTop,i,ts,ls
	sqlTop="Select Top "&TopNum&" " & Db.UserID & "," & Db.UserName & "," & Db.UserEmail & "," & Db.UserJoinDate & "," & Db.UserLastLogin & "," & Db.UserLogins & "," & Db.UserLastIP & "," & Db.DataCount & "," & Db.UserGroupID& "," & Db.UserPoint & "," & Db.UserMoney & " from " & Db.UserTable & " where " & Db.UserLock & "=0 "
	Select Case ShowType
	Case 0
		sqlTop=	sqlTop & " Order by " & Db.UserID & " "&OrderType&"":ts="用户ID":ls=0
	Case 1
		sqlTop=	sqlTop & " Order by " & Db.DataCount & " "&OrderType&"," & Db.UserID & " Asc":ts="发表":ls=7
	Case 2
		sqlTop=	sqlTop & " Order by " & Db.UserMoney & " "&OrderType&"," & Db.UserID & " Asc":ts="金钱":ls=10
	Case 3
		sqlTop=	sqlTop & " Order by " & Db.UserPoint & " "&OrderType&"," & Db.UserID & " Asc":ts="点数":ls=9
	Case 4
		sqlTop=	sqlTop & " Order by " & Db.UserLogins & " "&OrderType&"," & Db.UserID & " Asc":ts="登录":ls=5
	Case 5
		sqlTop=	sqlTop & " Order by " & Db.UserGroupID & " "&OrderType&"," & Db.UserID & " Asc":ts="等级":ls=8
	Case Else
		sqlTop=	sqlTop & " Order by " & Db.UserID & " Desc":ts="注册":ls=3
	End Select
	set rsTop=Cl.Execute_U(sqlTop)
	if rsTop.bof and rsTop.eof then
		ShowTopUser = "当前无记录"
		rsTop.Close : Set rsTop=Nothing : Exit Function
	end if
	sqlTop = rsTop.GetRows(-1)
	rsTop.Close : Set rsTop=Nothing
	Dim sTemp
	sTemp="<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""0""><tr><td align=""left"" width=""40"">名次</td><td align=""left"">用户名</td><td align=""right"">"&ts&"</td></tr>"
	if ls=3 then
		For i=0 to Ubound(sqlTop,2)
		sTemp=sTemp & "<tr><td align=""center"">" & (i+1) & "</td><td align=""left""><a href="""&Cl.WebDir&"User/Info.asp?UserID=" & sqlTop(0,i) & """>" & sqlTop(1,i) & "</a></td><td align=""right"">" & formatdatetime(sqlTop(ls,i),2)& "</td></tr>"
		next
	else
		For i=0 to Ubound(sqlTop,2)
		sTemp=sTemp & "<tr><td align=""center"">" & (i+1) & "</td><td align=""left""><a href="""&Cl.WebDir&"User/Info.asp?UserID=" & sqlTop(0,i) & """>" & sqlTop(1,i) & "</a></td><td align=""right"">" & sqlTop(ls,i) & "</td></tr>"
		next
	end if
	sTemp=sTemp & "<tr><td align=""right"" colspan=""3""><a href="""&Cl.WebDir&"User/List.asp"">more...</a></td></tr>"
	sTemp=sTemp & "</table>"
	ShowTopUser=sTemp
	sqlTop=Empty
End Function
'=====================================================
'ShowGuest(TopNum,TitleLen,ShowReply)
'参数：
'	TopNum		-----	显示记录数
'	TitleLen	-----	标题字节数
'	ShowReply	-----	是否显示已回复字样（True为是）
'=====================================================
Function ShowGuest(Byval TopNum,Byval TitleLen,Byval ShowReply)
	TopNum=Cl.GetClng(TopNum)
	TitleLen=Cl.GetClng(TitleLen)
	ShowReply=Cl.GetCBool(ShowReply)
	if TopNum=0 then TopNum=8
	dim sqlGuest,rsGuest
	sqlGuest="select top "&TopNum&" UserID,UserName,GuestId,GuestTitle,GuestTime,ReplyCount from Cl_Guest where Status=1 order by GuestID desc"
	Set rsGuest= Cl.Execute(sqlGuest)
	if rsGuest.bof and rsGuest.eof then
		ShowGuest="没有任何留言"
		rsGuest.Close:Set rsGuest=Nothing:Exit Function
	End if
	sqlGuest=RsGuest.GetRows(-1)
	rsGuest.Close:Set rsGuest=Nothing
	dim i,sTemp
	sTemp="<ul>"
	for i=0 to Ubound(sqlGuest,2)
		sTemp=sTemp & "<li><span class=""title""><a href="""&Cl.WebDir&"GuestBook/Show.asp?GuestID="&sqlGuest(2,i)&""" target=""_blank"">"
		sTemp=sTemp & Cl.GotTopic(sqlGuest(3,i),TitleLen)
		sTemp=sTemp & "</a></span>"
		if ShowReply then
			sTemp=sTemp & "<span class=""replycount"">"&sqlGuest(5,i)&"</span>"
		end If
		sTemp=sTemp & "</li>"
	Next
	ShowGuest=sTemp & "</ul>"
	sqlGuest=Empty
End Function

'==================================================================
'过程：ShowAD(sAdID,sType,sAct,sWidth,sHeight)
'参数：
'	sAdID			------  ADID
'   sType			------  0=图片，1=代码
'	sAct			------  0=普通，1=弹出，2=浮动，3=固定
'	sWidth			------  宽度
'	sHeight			------  高度
'==================================================================
Function ShowAD(Byval sAdID,Byval sType,Byval sAct,Byval sWidth,Byval sHeight)
	dim sqlAD,rsAD,sTempAD
	On Error Resume Next
	sAdID	= Clng(sAdID)
	sType	= Clng(sType)
	sAct	= Clng(sAct)
	sWidth	= Clng(sWidth)
	sHeight	= Clng(sHeight)
	if Err then Err.Clear : ShowAD="ShowAD参数错误。" : Exit Function
	On Error GoTo 0
	if sAdID>0 then
		sqlAD="Select ID,AdName,AdLinkUrl,AdImgUrl,ImgWidth,ImgHeight,IsFlash,ADType,AdAct,ADSetting from Cl_Ads where ID=" & sAdID & " and IsUse=1"
	else
		sqlAD="Select Top 1 ID,AdName,AdLinkUrl,AdImgUrl,ImgWidth,ImgHeight,IsFlash,ADType,AdAct,ADSetting from Cl_Ads where AdAct=" & sAct & " and IsUse=1 and AdType="&sType&""
	end if
	Set rsAD=Cl.Execute(sqlAD)
	if rsAd.bof and rsAD.eof then
		rsAD.Close : Set rsAD=Nothing
		ShowAD = "" : Exit Function
	end if
	Select Case rsAd(7)
	Case 0
		if sWidth	= 0 then sWidth	= rsAd(4)
		if sHeight	= 0 then sHeight= rsAd(5)
		if rsAd(6)=true then
			sTempAD = "<object classid=""clsid:D27CDB6E-AE6D-11cf-96B8-444553540000"" codebase=""http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=5,0,0,0"" width=""" & sWidth & """ height=""" & sHeight & """>"
			sTempAD = sTempAD & "<param name=""movie"" value=""" & rsAd(3) & """><param name=""quality"" value=""high""><embed src=""" & rsAd(3) & """ pluginspage=""http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash"" type=""application/x-shockwave-flash"" width=""" & sWidth & """ height=""" & sHeight & """>"
			sTempAD = sTempAD & "</embed></object>"
		else
			sTempAd = "<a href=""" & rsAd(2) & """ target=""_blank"" title=""" & rsAd(1) & """><img src=""" & rsAd(3) & """ width=""" & sWidth & """ height=""" & sHeight & """ border=""0"" alt="""" /></a>"
		end if
		'sTempAD = Replace(Replace(sTempAD,"'",""),vbcrlf,"\n")
		Dim AdSetting
		AdSetting = split(rsAd(9),"|")
		if Clng(AdSetting(1)) = 0 then AdSetting(1) = 100
		if Clng(AdSetting(2)) = 0 then AdSetting(2) = 100
		Select Case rsAd(8)
		Case 0
			ShowAD = sTempAD
		Case 1
			ShowAD = Template.GetTemplate(Cl.GetDefaultTemplateID(-1,6,Template.ProjectID))
			ShowAD = Replace(ShowAD,"{$adid}",sAdID)
			ShowAD = Replace(ShowAD,"{$width}",sWidth)
			ShowAD = Replace(ShowAD,"{$height}",sHeight)
			ShowAD = Replace(ShowAD,"{$popleft}",AdSetting(1))
			ShowAD = Replace(ShowAD,"{$poptop}",AdSetting(2))
			ShowAD = "<script type=""text/javascript"">" & vbcrlf & Cl.ReplaceDir(ShowAD) & "</script>"
		Case 2
			ShowAD = "<div id=""FlAD_"&sAdID&""" style=""position:absolute; z-index:10;left: "&AdSetting(1)&"; top: "&AdSetting(2)&""">" & sTempAD & "</div>"
			ShowAD = ShowAD & VbCrlf & "<script type=""text/javascript"">" & vbcrlf & Replace(Template.GetTemplate(Cl.GetDefaultTemplateID(-1,7,Template.ProjectID)),"{$adid}",sAdID) & "</script>"
		Case 3
			ShowAD = "<div id=""FixAD_"&sAdID&""" style=""position:absolute; z-index:10;left: "&AdSetting(1)&"; top: "&AdSetting(2)&""">" & sTempAD & "</div>"
			ShowAD = ShowAD & VbCrlf & "<script type=""text/javascript"">" & vbcrlf & Replace(Template.GetTemplate(Cl.GetDefaultTemplateID(-1,8,Template.ProjectID)),"{$adid}",sAdID) & "</script>"
		End Select
	Case 1
		ShowAD = Cl.ReplaceDir(rsAd(3))
	Case Else
		ShowAD = ""
	End Select
	rsAD.Close : Set rsAD=Nothing
End Function
'==================================================================
'过程：ShowComment(sChannelID,InfoID,TopNum)
'参数：
'	sChannelID		------  频道ID
'	InfoID			------  内容ID
'	TopNum			------  最多显示数
'==================================================================
Function ShowComment(Byval sChannelID,Byval InfoID,Byval TopNum)
	Dim rsComment,sqlComment,rsCommentU,NoPassedNum,i
	'NoPassedNum=Cl.Execute("Select Count(CommentID) from Cl_Comment where ChannelID="&sChannelID&" and InfoID=" & InfoID & " and Status=0")(0)
	'if NoPassedNum="" then NoPassedNum=0
	sChannelID		= Cl.GetClng(sChannelID)
	InfoID			= Cl.GetClng(InfoID)
	TopNum			= Cl.GetClng(TopNum)
	if TopNum > 0 And TopNum<20 then
		sqlComment = "select top " & TopNum & " "
	else
		sqlComment = "select top 8 "
	end if
	sqlComment=sqlComment & " CommentID,InfoID,UserID,UserName,UserGroupID,UserEmail,CommentTime,CommentContent,Status from Cl_Comment where ChannelID="&sChannelID&" and InfoID=" & InfoID & " "
	'if Cl.UserGroupID=1 then
	'sqlComment=sqlComment & " order by CommentID desc"
	'else
	sqlComment=sqlComment & " and Status=1 order by CommentID desc"
	'end if
	Set rsComment = Cl.Execute(sqlComment)
	if rsComment.bof and rsComment.eof then
		'if NoPassedNum>0 then
		'	ShowComment="<li style=""text-align:right;"">待审评论 <b><font color=""#FF0033"">"&NoPassedNum&"</font></b> 条，请管理员 <a href="""&Cl.WebDir&"User/Login.asp""><font color=""#FF0033"">登录</font></a> 后操作！</li>"
		'else
			ShowComment="<li>没有任何评论</li>"
		'end if
		rsComment.close:set rsComment=Nothing
	else
		Set ClUbb=New Cls_UbbCode
		Dim sTemp,UserIM
		sTemp="<div class='commentlist'><ul>"
		Do While Not rsComment.Eof
			sTemp=sTemp & "<li>"&Cl.GetUserGroupName(rsComment("UserGroupID"))&"『"
			sTemp=sTemp & "<a href=""" & Cl.WebDir & "User/Info.asp?UserName=" & rsComment("UserName") & """><font color=""blue"">" & rsComment("UserName") & "</font></a>"
			sTemp=sTemp & "』于" & rsComment("CommentTime") & "发表评论："
			'if Cl.UserGroupID=1 then
			'	if rsComment("Status")=1 then
			'	sTemp=sTemp & "&nbsp;[<a href="""&Cl.WebDir&"Comment/Property.asp?Action=Check&Type=N&CommentID="&rsComment("CommentID")&""">取消</a>]"
			'	else
			'	sTemp=sTemp & "&nbsp;[<a href="""&Cl.WebDir&"Comment/Property.asp?Action=Check&Type=P&CommentID="&rsComment("CommentID")&"""><font color=""#FF0033"">审核</font></a>]"
			'	end if
				'sTemp=sTemp & "&nbsp;[<a href="""&Cl.WebDir&"Comment/Property.asp?Action=Check&Type=M&CommentID="&rsComment("CommentID")&""">修改</a>]"
			'	sTemp=sTemp & "&nbsp;[<a href="""&Cl.WebDir&"Comment/Property.asp?Action=Check&Type=D&CommentID="&rsComment("CommentID")&""">删除</a>]"
			'end if
			sTemp=sTemp & "<br />"
			sTemp=sTemp & "&nbsp;&nbsp;&nbsp;&nbsp;" & ClUbb.UbbCode(rsComment("CommentContent")) & "<br />"
			sTemp=sTemp & "</li>"
			rsComment.MoveNext
		Loop
		rsComment.close:set rsComment=Nothing
		Set ClUbb=Nothing
		sTemp=sTemp & "</ul><ul><li style=""text-align:right;"">"
		'if NoPassedNum>0 then
		'sTemp=sTemp & "待审评论 <b><font color=""red"">"&NoPassedNum&"</font></b> 条，请管理员 <a href="""&Cl.WebDir&"User/Login.asp""><font color=""#FF0033"">登录</font></a> 后操作！"
		'end if
		sTemp=sTemp & "&nbsp;&nbsp;&nbsp;&nbsp;<a href="""&Cl.WebDir&"Comment/List.asp?ChannelID="&sChannelID&"&InfoID=" & InfoID & """>查看所有评论</a></li>"
		sTemp=sTemp & "</ul></div>"
		ShowComment=sTemp
	end if
	sqlComment=Empty
End Function

'=======================================================================
'显示相关信息
'ShowCorrelative(sChannelID,sInfoID,TopNum,TitleLen,ShowHits)
'	sChannelID
'	sInfoID
'	TopNum		------	(文章数量)
'	TitleLen	------	(标题字符数)
'	ShowHits	------	(是否显示点击数，True为是)
'=======================================================================
Function ShowCorrelative(Byval sChannelID,ByVal sInfoID,Byval TopNum,Byval TitleLen,Byval ShowHits)
	Dim Rs,SQL,SQLC,LinkUrl,sTemp
	Dim KeywordStr,arrKey,i
	'On Error Resume Next
	sChannelID	= CLng(sChannelID)
	sInfoID		= CLng(sInfoID) : ShowHits = CBool(ShowHits)
	TopNum		= CLng(TopNum)	: TitleLen = CLng(TitleLen)
	if Err then Err.Clear : ShowCorrelative = "ShowCorrelative参数错误。" : Exit Function
	On Error GoTo 0
	Cl.Load_ChannelSetting(ChannelID)
	Select Case Cint(Cl.Channel.selectSingleNode("@moduleid").text)
	Case 1
		SQL = "Select Keyword from Cl_Article Where InfoID=" & InfoID
		SQLC = "InfoID,ChannelID,ChannelDir,Title,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Article"
	Case 2
		SQL = "Select Keyword from Cl_Soft Where InfoID=" & InfoID
		SQLC = "InfoID,ChannelID,ChannelDir,SoftName,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Soft"
	Case 3
		SQL = "Select Keyword from Cl_Photo Where InfoID=" & InfoID
		SQLC = "InfoID,ChannelID,ChannelDir,PhotoName,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Photo"
	Case 4
		SQL = "Select Keyword from Cl_Movie Where InfoID=" & InfoID
		SQLC = "InfoID,ChannelID,ChannelDir,MovieName,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Movie"
	Case 5
		SQL = "Select Keyword from Cl_Product Where InfoID=" & InfoID
		SQLC = "InfoID,ChannelID,ChannelDir,ProductName,UpdateTime,Hits,IsHtml,HtmlFileUrl From Cl_Product"
	Case Else
		Exit Function
	End Select
	Set Rs = Cl.Execute(SQL)
	If Rs.Eof Then
		Set Rs = Nothing : Exit Function
	End If
	KeywordStr = rs(0)
	Set Rs = Nothing
	if TopNum>0 then
		SQL = "select top " & TopNum & " "
	else
		SQL = "Select Top 5 "
	end if
	if InStr(KeywordStr,"|")>1 then
		arrKey = Split(KeywordStr,"|")
		KeywordStr="((Keyword like '%" & arrKey(0) & "%')"
		for i=1 to ubound(arrKey)
			KeywordStr=KeywordStr & " or (Keyword like '%" & arrKey(i) & "%')"
		next
		KeywordStr=KeywordStr & ")"
	else
		KeywordStr="(Keyword like '%" & KeywordStr & "%')"
	end if
	SQL=SQL & SQLC & " Where ChannelID="&sChannelID&" and Deleted="&FalseType&" and Status=1 and " & KeywordStr & " and InfoID<>" & InfoID & " Order by UpdateTime desc,InfoID desc"
	Set Rs = Cl.Execute(SQL)
	sTemp = "<ul>"
	if Rs.bof and Rs.Eof then
		sTemp = sTemp & "<li>当前没有记录！</li>"
	else
		do while not Rs.eof
			if Rs(6)=True then
				LinkUrl=Cl.WebDir & Rs(7)
			else
				LinkUrl=Cl.WebDir & Rs(2) & "/ShowInfo.asp?InfoID="&Rs(0)
			end if
1234

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -