news.asp

此程序是一个个人主页创造程序,该程序无插件,无任何恶意程序.

<%@ Language=VBScript %>
<%
'#############################################################
'#      中国在线--极酷论坛 ver.2001 3.0
'#
'#  版权所有: 中国在线 (ChinaXP.Net)
'#
'#  制作人  : 周周 (SeeYa!)
'#
'#
'#  主页地址: http://www.ChinaXP.net/    中国在线
'#	      http://www.ChinaXP.Net/bbs/    中国在线--极酷论坛
'#
'#############################################################
%>
<!--#INCLUDE FILE="Conn.asp" -->
<%
' ############################################################
' ###  调用方法：<SCRIPT src="news.asp?Show=12"></SCRIPT>  ###
' ############################################################

Dim strConnString, conn, strSQL, RS, strDateType
Dim i, strSubject, strTrueSubject, strNews
Dim strShowLen, strMaxLen, strPath
Dim m_bOverFlow, strTip

' ############################# 命令行参数及设置初始变量 #############################
  strMaxLen = 44	' ### 每条信息最多显示字符(双数)
  strShowLen = 8	' ### 设定显示条数
  strPath = "http://" & Request.ServerVariables("SERVER_NAME") & "/bbs/"
			' ### 论坛所在路径，必须含有 "/" 字符，可以是其他服务器上的BBS，
			' 如：http://www.ChinaXP.Net/bbs/news.asp?Show=12&path=http://www.chinaxp.net/bbs/
  strDateType = "mmdd"	' ### 设置日期显示格式，其他格式参见 ChkDate() 函数
  strHead = "<font color=red>□</font> "	
			' ### 显示在贴子头部的字符 ☆
  strForumId = ""	' ### 显示最新贴子的论坛 ID 编号，参数名称：FORUM_ID
' ####################################################################################

if Request.QueryString("Max") <> "" then
	strMaxLen = Request.QueryString("Max")
end if
if not IsNull(Request.QueryString("Show")) then
	if Request.QueryString("Show") > 8 and Request.QueryString("Show") <= 20 then
		strShowLen = Request.QueryString("Show")
	end if
end if
if Request.QueryString("FORUM_ID")<>"" or IsNumeric(Request.QueryString("FORUM_ID")) then
	strForumId = Request.QueryString("FORUM_ID")
end if
if Request.QueryString("Path") <> "" then
	if Right(Trim(Request.QueryString("Path")),1) = "/" then
		strPath = Request.QueryString("Path")
	end if
end if
if Request.QueryString("Head") <> "" then
	strHead = Request.QueryString("Head")
end if

strConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(dbPath)
set conn=Server.CreateObject("ADODB.Connection")
conn.Open strConnString
SET strConnString = Nothing

strSQL = "SELECT top " & strShowLen & " TOPIC_ID, T_SUBJECT, T_LAST_POST,T_DATE FROM FORUM_TOPICS"
if strForumId<>"" then
	strSQL = strSQL & " WHERE FORUM_ID = " & strForumId
end if
strSQL = strSQL & " ORDER BY T_LAST_POST DESC"
set RS = Conn.Execute(strSQL)

i=0
if NOT(RS.EOF or RS.BOF) then
	Do while Not RS.EOF
		if i < strShowLen then
			strSubject = RS("T_SUBJECT")
			'if Len(strSubject) > strMaxLen then
			'	strSubject = Left(strSubject, strMaxLen) & "..."
			'end if
			strTrueSubject = GetTrueLength(strSubject, strMaxLen)
			m_bOverFlow = CheckOverFlow(strSubject, strMaxLen)
			if m_bOverFlow = True then
				strTip = strSubject
			else
				strTip = ""
			end if

			strNews = strHead & " <A Href=" & strPath & "Link.asp?TOPIC_ID=" & RS("TOPIC_ID") & " title=""" & strTip & """ target=_blank>" & strTrueSubject & "</A> <FONT color=#666666>(" & ChkDate(RS("T_LAST_POST")) & ")</FONT><BR>"
			Response.Write ("document.write('" & strNews & "');")
		else
			exit do
		end if
		i = i + 1
		RS.MoveNext
	Loop
else
	Response.Write ("document.write('论坛还没有新文章发表或该论坛不存在！');")
	Response.End
End if

RS.close
SET RS = Nothing
conn.close
SET Conn = Nothing

function ChkDate(fDate)
	if fDate = "" or vartype(fDate) = vbNull then
		exit function
	end if
	'if IsDate(fDate) then
		select case strDateType
			case "dmy"
				ChkDate = Mid(fDate,7,2) & "/" & _
				Mid(fDate,5,2) & "/" & _
				Mid(fDate,1,4)
			case "mdy"
				ChkDate = Mid(fDate,5,2) & "/" & _
				Mid(fDate,7,2) & "/" & _
				Mid(fDate,1,4)
			case "ymd"
				ChkDate = Mid(fDate,1,4) & "/" & _
				Mid(fDate,5,2) & "/" & _
				Mid(fDate,7,2)
			case "ydm"
				ChkDate =Mid(fDate,1,4) & "/" & _
				Mid(fDate,7,2) & "/" & _
				Mid(fDate,5,2)
			case "dmmy"
				ChkDate = Mid(fDate,7,2) & " " & _
				Monthname(Mid(fDate,5,2),1) & " " & _
				Mid(fDate,1,4)
			case "mmdy"
				ChkDate = Monthname(Mid(fDate,5,2),1) & " " & _
				Mid(fDate,7,2) & " " & _
				Mid(fDate,1,4)
			case "ymmd"
				ChkDate = Mid(fDate,1,4) & " " & _
				Monthname(Mid(fDate,5,2),1) & " " & _
				Mid(fDate,7,2)
			case "ydmm"
				ChkDate = Mid(fDate,1,4) & " " & _
				Mid(fDate,7,2) & " " & _
				Monthname(Mid(fDate,5,2),1)
			case "dmmmy"
				ChkDate = Mid(fDate,7,2) & " " & _
				Monthname(Mid(fDate,5,2),0) & " " & _
				Mid(fDate,1,4)
			case "mmmdy"
				ChkDate = Monthname(Mid(fDate,5,2),0) & " " & _
				Mid(fDate,7,2) & " " & _
				Mid(fDate,1,4)
			case "ymmmd"
				ChkDate = Mid(fDate,1,4) & " " & _
				Monthname(Mid(fDate,5,2),0) & " " & _
				Mid(fDate,7,2)
			case "ydmmm"
				ChkDate = Mid(fDate,1,4) & " " & _
				Mid(fDate,7,2) & " " & _
				Monthname(Mid(fDate,5,2),0)
			case "mmdd"
				ChkDate = Mid(fDate,5,2) & "/" & _
				Mid(fDate,7,2)
			case else
				ChkDate = Mid(fDate,5,2) & "/" & _
				Mid(fDate,7,2) & "/" & _
				Mid(fDate,1,4)
		End Select
	'end if
end function

function CheckOverFlow(strChinese, lenMaxWord)
	'判断字符长度是否溢出
	'strChinese 为被检测字符串
	'lenMaxWord 为限制的字符长度

	dim i, lenTotal, strWord

	if strChinese = "" or vartype(strChinese) = vbNull or CLng(lenMaxWord) <= 0 then
		CheckOverFlow = False
		exit function
	end if

	lenTotal = 0
	for i=1 to Len(strChinese)
		strWord = mid(strChinese, i, 1)
		if asc(strWord) < 0 or asc(strWord) > 255 then
			lenTotal = lenTotal + 2
		else
			lenTotal = lenTotal + 1
		end if
	next

	'判断字符是否溢出
	if lenTotal > lenMaxWord then
		CheckOverFlow = True
	else
		CheckOverFlow = False
	end if
end function

function GetTrueLength(strChinese, lenMaxWord)
	'截取正确的英文/汉字长度
	'strChinese 为被检测字符串
	'lenMaxWord 为限制的字符长度

	dim i, strTail, lenTotal, lenWord
	dim strWord, bOverFlow, RetString

	if strChinese = "" or vartype(strChinese) = vbNull or CLng(lenMaxWord) <= 0 then
		GetTrueLength = ""
		exit function
	end if

	strTail = " ..."
	bOverFlow = False

	lenTotal = 0
	for i=1 to Len(strChinese)
		strWord = mid(strChinese, i, 1)
		if asc(strWord) < 0 or asc(strWord) > 255 then
			lenTotal = lenTotal + 2
		else
			lenTotal = lenTotal + 1
		end if
	next
	'判断字符是否溢出
	if lenTotal > lenMaxWord then bOverFlow = True

	if bOverFlow = True then
		'字符溢出,去尾
		lenWord = 0
		RetString = ""
		for i=1 to Len(strChinese)
			strWord = mid(strChinese, i, 1)
			if asc(strWord) < 0 or asc(strWord) > 255 then
				lenWord = lenWord + 2
			else
				lenWord = lenWord + 1
			end if
			'截掉多余部分
			if lenWord <= (lenMaxWord - Len(strTail)) then
				RetString = RetString + strWord
			else
				GetTrueLength = RetString + strTail
				exit for
			end if
		next
	else
		'字符不溢出
		GetTrueLength = strChinese
	end if
end function
%>