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 HotImg(NewsID,i)
If not IsObjInstalled(ServerObject(9)) Then
Response.Write ""
else
On Error Resume Next
set DelectFile=server.CreateObject("scripting.filesystemobject")
CurrentPath=server.MapPath(ImgPath)+"/"
FileName=CurrentPath & NewsID & "-" & i & ".jpg"
if DelectFile.FileExists(FileName) then
HotImg=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".gif"
if DelectFile.FileExists(FileName) then
HotImg=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".png"
if DelectFile.FileExists(FileName) then
HotImg=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".swf"
if DelectFile.FileExists(FileName) then
HotImg=""
exit function
else
HotImg=""
exit function
end if
end if
end if
end if
end if
end function
'检查图片
function DelectImageFile(NewsID,i)
If not IsObjInstalled(ServerObject(9)) Then
Response.Write ""
else
set DelectFile=server.CreateObject("scripting.filesystemobject")
CurrentPath=server.MapPath(ImgPath)+"/"
FileName=CurrentPath & NewsID & "-" & i & ".jpg"
if DelectFile.FileExists(FileName) then
DelectImageFile=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".gif"
if DelectFile.FileExists(FileName) then
DelectImageFile=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".png"
if DelectFile.FileExists(FileName) then
DelectImageFile=""
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".swf"
if DelectFile.FileExists(FileName) then
DelectImageFile=""
exit function
else
DelectImageFile=""
exit function
end if
end if
end if
end if
end if
end function
'上传图片
function DelectImageFile_Upload(NewsID,i)
set DelectFile=server.CreateObject("scripting.filesystemobject")
CurrentPath=server.MapPath("&ImgPath&")
FileName=CurrentPath & NewsID & "-" & i & ".gif"
if DelectFile.FileExists(FileName) then
DelectImageFile_Upload= NewsID & "-" & i & ".gif"
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".jpg"
if DelectFile.FileExists(FileName) then
DelectImageFile_Upload= NewsID & "-" & i & ".jpg"
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".png"
if DelectFile.FileExists(FileName) then
DelectImageFile_Upload= NewsID & "-" & i & ".png"
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".swf"
if DelectFile.FileExists(FileName) then
DelectImageFile_Upload= NewsID & "-" & i & ".swf"
exit function
else
FileName=CurrentPath & NewsID & "-" & i & ".bmp"
if DelectFile.FileExists(FileName) then
DelectImageFile_Upload= NewsID & "-" & i & ".bmp"
exit function
else
DelectImageFile_Upload=""
exit function
end if
end if
end if
end if
end if
end function
'新闻图片调用处理
Function HtmlSelfEnCode(content,ImageNum)
Image=ImageNum
TempContent=content
if image>0 then
for i=1 to image
TempContent=replace(TempContent,"[[image" & i & "]]","" & DelectImageFile(NewsID,i) & "")
next
end if
TempContent=replace(TempContent,"[[left]]","")
TempContent=replace(TempContent,"[[/left]]","")
TempContent=replace(TempContent,"[[center]]","")
TempContent=replace(TempContent,"[[/center]]","")
TempContent=replace(TempContent,"[[right]]","")
TempContent=replace(TempContent,"[[/right]]","")
TempContent=replace(TempContent,"[["," TempContent=replace(TempContent,"]]",">")
HtmlSelfEnCode=TempContent
End Function
function checkOverFlow(strChinese, lenMaxWord)
'判断字符长度是否溢出
'strChinese 为被检测字符串,lenMaxWord 为限制的字符长度
dim i, lenTotal, strWord , firstChinese
if strChinese = "" or vartype(strChinese) = vbNull or CLng(lenMaxWord) 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
dim strWord, bOverFlow, RetString
if strChinese = "" or vartype(strChinese) = vbNull or CLng(lenMaxWord) 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 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 + " "
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 + " "
next
end if
GetTrueLength = RetString
end if
end function
'定义新闻通用选择句
NoContent=" NewsID,Title,model,BigClassName,SmallClassName,SpecialName,author,original,UpdateTime,image,click,goodnews "
function NewsUrl '定义新闻标题URL
model=rs("model")
if model=0 then
model=""
end if
newsurl="shownews"&model&".asp?newsid=" & rs("NewsID")
end function
function showTitle(strClass,strMaxLen) '定义标题及链接
'strClass 为显示格式（即class="格式"的值，必须用双引号表示）
'strMaxLen 为显示长度（偶数）
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
if strClass="" then strClass="MainContentS"
Response.Write ""&strTrueSubject&""
end function
function showTime '定义时间显示格式
'这里默认当为NEW时，日期为红色
if DateValue(rs("updatetime"))=>DateValue(date()-Indate) then
fontcolor=""
else
fontcolor=""
end if
Response.Write " (" & fontcolor & DateValue(rs("UpdateTime"))&")"
end function
function showImg '定义有图的新闻标志
if rs("image")>0 then showImg="[图]"
end function
function showClick '定义点击格式
showClick="[" & rs("click") &"]"
end function
function HTMLDecode(fString)
fString = replace(fString, "&", "&")
fString = replace(fString, ">", ">")
fString = replace(fString, "<", " fString = replace(fString, """, Chr(34))
fString = Replace(fString, "…", "...")
HTMLDecode = fString
end function
Function Space(strHeight) '定义栏与栏之间的间隔
if strHeight="" then strHeight=THeight
if strHeight0 then Response.Write ""
end function
Function trline() '定义有关页题目与标题之间的分隔条
Response.Write ""
end function
Function OutTable(strside) '定义外框格式
if strside="left" then Response.Write ""
if strside="right" then Response.Write ""
end function
Function InTable(strside) '定义内框格式
if strside="left" then Response.Write "" '左竖隔栏
if strside="right" then Response.Write "" '右竖隔栏
if strside="bottoml" then Response.Write "" '左横隔栏
if strside="bottomr" then Response.Write "" '右横隔栏
if strside="middle1" then Response.Write "" '中横隔栏无分列
if strside="middle2" then Response.Write "" '中横隔栏有分列
end function
%>
