function.asp

庐江二中

<%
'----------------------------------------------------------
'如果你对ASP不熟，请不要随意修改本程序，否则将导致系统瘫痪。
'----------------------------------------------------------
Dim ServerObject(9)
ServerObject(9) = "Scripting.FileSystemObject"

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

'检查图片格式
function ImageFile(NewsID,i,strwidth,strheight)
dim imgwidth,imgheight,FSO,CurrentPath,ext,strTitle
if strwidth>0 then imgwidth=" width="&strwidth
if strheight>0 then imgheight=" height="&strheight
'If not IsObjInstalled(ServerObject(9)) Then
'ImageFile="<img src="""&ImgPath& NewsID&"-"&i&".jpg"" border=""0"" "& imgwidth & imgheight& ">"	'如果不支持FSO，则只显示JPG图片
'else	
set FSO=server.CreateObject("scripting.filesystemobject")
CurrentPath=server.MapPath(ImgPath)+"\"&NewsID&"-"&i 
if FSO.FileExists(CurrentPath & ".bmp") then ext=".bmp"
if FSO.FileExists(CurrentPath & ".swf") then ext=".swf"
if FSO.FileExists(CurrentPath & ".png") then ext=".png"
if FSO.FileExists(CurrentPath & ".gif") then ext=".gif"
if FSO.FileExists(CurrentPath & ".jpg") then ext=".jpg"
set FSO=nothing
select case ext
case ".gif",".bmp",".jpg",".png":
	if PageName="shownews" and strwidth=0 then
		dim qswh,arr
		set qswh=new qswhImg
		arr=qswh.getImageSize(CurrentPath&ext)
		if ShowNewsModelRight=1 then
			if arr(1)>570 then
				imgwidth=" width=570"
				strTitle=" title=""点击放大图片"""
			end if
		else
			if arr(1)>700 then
				imgwidth=" width=700"
				strTitle=" title=""点击放大图片"""
			end if
		end if		
		Set qswh=nothing	
		ImageFile="<a href="""&ImgPath& NewsID&"-"&i&ext&""" target=""_blank"" "&strTitle&"><img src="""&ImgPath& NewsID&"-"&i&ext&""" border=1 "& imgwidth &"></a>"
	else	
		ImageFile="<a href=""shownews.asp?newsid="&NewsID&""" target=""_blank""><img src="""&ImgPath& NewsID&"-"&i&ext&""" border=""1"" "& imgwidth & imgheight&"></a>"
	end if
case ".swf"
	ImageFile="<embed src="""&ImgPath& NewsID & "-" & i & ".swf"" pluginspage=""http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash"" type=""application/x-shockwave-flash"" "& imgwidth & imgheight&"></embed>"
	case else
		ImageFile="<img src="""&ImgPath& "error.jpg"" border=""0"" "& imgwidth &imgheight&" alt=""图片不存在:("">"
end select
'end if
end function

'文章图片位置处理
Function HtmlSelfEnCode(strcontent,ImageNum)
if ImageNum>0 then
for i=1 to ImageNum
StrContent=replace(StrContent,"[[image" & i & "]]","" & ImageFile(NewsID,i,0,0) & "")
next
StrContent=replace(StrContent,"[[left]]","<table border=0 cellspacing=5 cellpadding=0 align=left><tr><td>")
StrContent=replace(StrContent,"[[/left]]","</td></tr></table>")
StrContent=replace(StrContent,"[[center]]","<table border=0 cellspacing=5 cellpadding=0 align=center><tr><td>")
StrContent=replace(StrContent,"[[/center]]","</td></tr></table>")
StrContent=replace(StrContent,"[[right]]","<table border=0 cellspacing=5 cellpadding=0 align=right><tr><td>")
StrContent=replace(StrContent,"[[/right]]","</td></tr></table>")
StrContent=replace(StrContent,"[[","<")
StrContent=replace(StrContent,"]]",">")
end if
HtmlSelfEnCode=StrContent
End Function

'判断上传图片格式
function DelectImageFile_Upload(NewsID,i)
set FSO=server.CreateObject("scripting.filesystemobject")
CurrentPath=server.MapPath(ImgPath)+"\"& NewsID & "-" & i 
dim ext
if FSO.FileExists(CurrentPath & ".bmp") then ext=".bmp"
if FSO.FileExists(CurrentPath & ".swf") then ext=".swf"
if FSO.FileExists(CurrentPath & ".png") then ext=".png"
if FSO.FileExists(CurrentPath & ".gif") then ext=".gif"
if FSO.FileExists(CurrentPath & ".jpg") then ext=".jpg"
set FSO=nothing
if ext<>"" then
DelectImageFile_Upload= NewsID & "-" & i & ext
else
DelectImageFile_Upload=""
end if
end function

'判断字符长度是否溢出	
function checkOverFlow(strChinese, lenMaxWord)
'strChinese 为被检测字符串,lenMaxWord 为限制的字符长度
dim i, lenTotal, strWord , firstChinese
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) > 127 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, strSpaceBar)
'strChinese 为被检测字符串,lenMaxWord 为限制的字符长度
dim i, j, strTail, lenTotal, lenWord, lenNow
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) > 127 then
lenTotal = lenTotal + 2
else
lenTotal = lenTotal + 1
end if
next
'判断字符是否溢出
if lenTotal > lenMaxWord then bOverFlow = True
strSpaceBar = ""
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) > 127 then lenNow = 2 else lenNow = 1
lenWord = lenWord + lenNow
'截掉多余部分
if lenWord <= (lenMaxWord - Len(strTail)) then
	RetString = RetString + strWord
else
	RetString = RetString + strTail
	lenWord = lenWord + Len(strTail) - lenNow
	if (lenMaxWord-lenWord)>0 then
		for j =1 to lenMaxWord-lenWord
		strSpaceBar = strSpaceBar + "&nbsp;"
		next
	end if
	GetTrueLength = RetString
	exit for
end if
next
else
'字符不溢出,填充空位
RetString = strChinese
if (lenMaxWord-lenTotal)>0 then
	for i =1 to lenMaxWord-lenTotal
		strSpaceBar = strSpaceBar + "&nbsp;"
	next
end if
	GetTrueLength = RetString '''''''& strSpaceBar 	'如果标题后面要补空格，把前面连续的'去掉
end if
end function

dim NoContent '定义文章通用选择句
NoContent=" NewsID,BigClassName,SmallClassName,SpecialName,Title,author,original,model,image,UpdateTime,click,goodnews "

function NewsUrl	'定义文章标题URL
dim model
if model=0 or model="" then
model=""
else
model=rs("model")
end if
newsurl="shownews"&model&".asp?newsid=" & rs("NewsID") 	
end function

function showTitle(strClass,strMaxLen)	'定义标题及链接
'strClass 为显示格式（即class="格式"的值，必须用双引号表示）
'strMaxLen 为显示长度（偶数）
dim strSubject,strTrueSubject,m_bOverFlow,strTip,strTarget, strSpaceBar
strSubject = HTMLDecode(rs("Title"))	
strTrueSubject = GetTrueLength(strSubject, strMaxLen, strSpaceBar)
m_bOverFlow = checkOverFlow(strSubject, strMaxLen)
if m_bOverFlow = True then
strTip = strSubject
else
strTip = ""
end if
strTarget="_blank"
if pagename="shownews" then strTarget="_self"
if strClass="" then strClass="MainContentS"
showTitle="<a class="&strClass&" href="""&newsurl&""" title="""&strTip&""" target="""&strTarget&""">"&strTrueSubject&"</a>"
end function			
			
function showTime      		'定义时间显示格式
showTime="<span Class=TitleMore>(" &Month(rs("UpdateTime"))&"-"&day(rs("UpdateTime"))&")</span>"
end function

function showImg					'定义“图”标志
if rs("image")>0 then showImg="[<font color="&AlertFColor&">图</font>]"
end function

function showNew					'定义标题后“新”标志
if DateValue(rs("updatetime"))=>DateValue(date()-Indate) then showNew=" <font color="&AlertFColor&">新</font>"
end function

function showNewf					'定义标题前的标志
if DateValue(rs("updatetime"))=>DateValue(date()-Indate) then 
showNewf="&nbsp;<img src=images/006.gif>&nbsp;"
else
showNewf="&nbsp;<img src=images/006.gif>&nbsp;"
end if
end function

function showClick					'定义点击格式
showClick="&nbsp;<font color="""&AlertFColor&""">" & rs("click") &"</font>"	
end function

function HTMLDecode(fString)
fString = replace(fString, "&amp;", "&")
fString = replace(fString, "&gt;", ">")
fString = replace(fString, "&lt;", "<")
fString = replace(fString, "&quot;", Chr(34))
fString = Replace(fString, "…", "...")
HTMLDecode = fString
end function

Function Space(strHeight)					'定义栏与栏之间的间隔
if strHeight="" then strHeight=THeight
if strHeight<>0 then Space="<table width=""90%"" border=""0"" height="&strHeight&" cellpadding=""0"" cellspacing=""0""><tr><td></td></tr></table>"
end function

Function trline()					'定义分页题目与标题之间的分隔条
trline="<tr><td width=""100%"" bgcolor=""#000000"" height=""1""></td></tr><tr><td height=""6""></td></tr>"
end function

Function OutTable(strside)					'定义主栏外框格式
OutTable=""
if strside="left" then 	'左边
	if Out1Color<>"" then OutTable=OutTable+"<TD BGCOLOR="&Out1Color&" WIDTH=1></TD>"
	OutTable=OutTable+"<TD BGCOLOR="&Out2Color&" WIDTH="&Out2Width&"></TD>"
	if LeftLColor<>"" then OutTable=OutTable+"<TD BGCOLOR="&LeftLColor&" WIDTH=1></TD>"
end if
if strside="right" then	'右边
	if RightRColor<>"" then OutTable=OutTable+"<TD BGCOLOR="&RightRColor&" WIDTH=1></TD>"
	OutTable=OutTable+"<TD BGCOLOR="&Out2Color&" WIDTH="&Out2Width&"></TD>"
	if Out1Color<>"" then OutTable=OutTable+"<TD BGCOLOR="&Out1Color&" WIDTH=1></TD>"
end if
end function

Function InTable(strside)					'定义主栏内框格式
if strside="left" then InTable="<TD BGCOLOR="""&LeftRColor&""" background="""&LeftRImg&""" WIDTH=1></TD>"	'左竖隔栏
if strside="right" then InTable="<TD BGCOLOR="""&RightLColor&""" background="""&RightLImg&""" WIDTH=1></TD>"  '右竖隔栏
if strside="bottoml" then InTable="<tr><TD BGCOLOR="""&LeftBColor&""" background="""&LeftBImg&""" HEIGHT=1></TD></tr>"   '左横隔栏
if strside="bottomr" then InTable="<tr><TD BGCOLOR="""&RightBColor&""" background="""&RightBImg&""" HEIGHT=1></TD></tr>"	'右横隔栏
if strside="middle1" then InTable="<tr><TD BGCOLOR="""&CenterBColor&""" background="""&CenterBImg&""" HEIGHT=1></TD></tr>"	'中横隔栏无分列
if strside="middle2" then InTable="<tr><TD BGCOLOR="""&CenterBColor&""" background="""&CenterBImg&""" HEIGHT=1 colspan=2></TD></tr>"	'中横隔栏有分列
end function
	
Function TTitle(strAdd,strTitle)	'定义栏目标题格式
if strAdd="left" then 		'左栏
	TTitle="<tr><td bgcolor="&LeftTColor&" height=25 align=center background="""&LeftTImg&""" class=LeftTitle>"&strTitle&"</td></tr>"
	TTitle=TTitle&InTable("bottoml")
end if
if strAdd="center_1" then 	'中栏非大类文章栏
	TTitle=InTable("middle1")
    TTitle=TTitle&"<tr><td bgcolor="&CenterTColor&" height=25 background="""&CenterTImg&"""><table width=100% ><tr><td valign=bottom class=MainTitle width=100% >&nbsp;<img src=""images/cat.gif"">&nbsp;"&strTitle&"</td></tr></table></td></tr>"
	TTitle=TTitle+InTable("middle1")
end if
if strAdd="center_12" then 	'焦点文章栏
	TTitle=InTable("middle1")
    TTitle=TTitle&"<tr><td bgcolor="&DaoDu_color&" height=25 background="""&DaoDu_img&"""><table width=100% ><tr><td valign=bottom class=MainTitle>&nbsp;<img src=""images/cat.gif"">&nbsp;"&strTitle&"</td><td align=right><a href=FocusNewsList.asp><img src=""images/more9.gif"" border=0 alt=更多焦点></a></td></tr></table></td></tr>"
	TTitle=TTitle+InTable("middle1")
end if
if strAdd="center_2" then 	'中栏大类文章栏
	TTitle=InTable("middle1")
    TTitle=TTitle&"<tr><td bgcolor="&CenterTColor&" height=25 background="""&CenterTImg&"""><table width=100% ><tr><td valign=bottom class=MainTitle>&nbsp;<img src=""images/cat.gif"">&nbsp;"&BigClassName&"("&totalNews&"条)</td><td align=right><a href="&classurl&"><img src=""images/more9.gif"" border=0 alt=更多></a></td></tr></table></td></tr>"
	TTitle=TTitle+InTable("middle1")
end if
if strAdd="right" then 		'右栏
	TTitle="<tr><td bgcolor="&rightTColor&" height=25 align=center background="""&rightTImg&""" class=RightTitle>"&strTitle&"</td></tr>"
	TTitle=TTitle&InTable("bottomr")
end if
end function	
%>