asp常用函数集合，非常不错以后研究 asp常用函数集合，非常不错以后研究
人气:0想了解asp常用函数集合，非常不错以后研究的相关内容吗，在本文为您仔细讲解asp常用函数集合，非常不错以后研究的相关知识和一些Code实例，欢迎阅读和指正，我们先划重点：asp,自定义标签，下面大家一起来学习吧。
<% function loadtempletfile(byval path)
on error resume next
dim objstream
set objstream = server.createobject("adodb.stream")
with objstream
.type = 2
.mode = 3
.open
.loadfromfile server.mappath(path)
if err.number <> 0 then
err.clear
response.write("预加载的模板[" & path & "]不存在!")
response.end()
end if
.charset = "" & chrset & ""
.position = 2
loadtempletfile = .readtext
.close
end with
set objstream = nothing
end function
function movefiles(sFolder,dFolder)
on error resume next
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(server.mappath(sFolder)) and fso.folderexists(server.mappath(dFolder)) then
fso.copyfolder server.mappath(sFolder),server.mappath(dFolder)
movefiles = true
else
movefiles = false
set fso = nothing
call alertbox("系统没有找到指定的路径[" & sFolder & "]!",2)
end if
set fso = nothing
end function
function renamefolder(sFolder,dFolder)
on error resume next
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(server.mappath(sFolder)) then
fso.movefolder server.mappath(sFolder),server.mappath(dFolder)
renamefolder = true
else
renamefolder = false
set fso = nothing
call alertbox("系统没有找到指定的路径[" & sFolder & "]!",2)
end if
set fso = nothing
end function
function checkfolder(sPATH)
on error resume next
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(server.mappath(sPATH)) then
checkfolder = true
else
checkfolder = false
end if
set fso = nothing
end function
function checkfile(sPATH)
on error resume next
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.fileexists(server.mappath(sPATH)) then
checkfile = true
else
checkfile = false
end if
set fso = nothing
end function
function createdir(sPATH)
dim fso,pathArr,i,path_Level,pathTmp,cPATH
on error resume next
sPATH = replace(sPATH,"\","/")
set fso = server.createobject("scripting.filesystemobject")
pathArr = split(sPATH,"/")
path_Level = ubound(pathArr)
for i = 0 to path_Level
if i = 0 then pathTmp = pathArr(0) & "/" else pathTmp = pathTmp&pathArr(i) & "/"
cPATH = left(pathTmp,len(pathTmp)-1)
if not fso.folderexists(cPATH) then fso.createfolder(cPATH)
next
set fso = nothing
if err.number <> 0 then
err.clear
createdir = false
else
createdir = true
end if
end function
function delclassfolder(sPATH)
on error resume next
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(server.mappath(sPATH)) then
fso.deletefolder(server.mappath(sPATH))
end if
set fso = nothing
end function
function delnewsfile(sPATH,filename)
on error resume next
dim fso,tempArr,cPATH,ePATH,i:i = 0
set fso = server.createobject("scripting.filesystemobject")
sPATH = sPATH & filename & site_extname
if fso.fileexists(server.mappath(sPATH)) then
fso.deletefile(server.mappath(sPATH))
while(i <> -1)
i = i + 1
ePATH = replace(sPATH,filename & ".",filename & "_" & i + 1 & ".")
if fso.fileexists(server.mappath(ePATH)) then
fso.deletefile(server.mappath(ePATH))
else
i = -1
end if
wend
end if
end function
class stringclass
public function getstr(strhtml)
dim PatrnStr
PatrnStr="<.*?>"
dim objRegEx
set objRegEx = new RegExp
objRegEx.pattern = PatrnStr
objRegEx.ignorecase = true
objRegEx.global = true
getstr = objRegEx.replace(strhtml,"")
set objRegEx = nothing
end function
public function replacestr(patrn,mstr,replstr)
dim objRegEx
set objRegEx = new RegExp
objRegEx.pattern = patrn
objRegEx.ignorecase = true
objRegEx.global = true
replacestr = objRegEx.replace(mstr,replstr)
set objRegEx = nothing
end function
public function classcustomtag(byval patrn,byval mstr,byval classid,byval indexid,byval pagestr)
dim objRegEx,match,matches
set objRegEx = new RegExp
objRegEx.pattern = patrn
objRegEx.ignorecase = true
objRegEx.global = true
set matches = objRegEx.execute(mstr)
for each match in matches
mstr = replace(mstr,match.value,parseclasstag(match.value,classid,indexid,pagestr))
next
set matches = nothing
set objRegEx = nothing
classcustomtag = mstr
end function
public function newscustomtag(byval patrn,byval mstr,byval classid,byval newsid,byval keywords)
dim objRegEx,match,matches
set objRegEx = new RegExp
objRegEx.pattern = patrn
objRegEx.ignorecase = true
objRegEx.global = true
set matches = objRegEx.execute(mstr)
for each match in matches
mstr = replace(mstr,match.value,parsenewstag(match.value,classid,newsid,keywords))
next
set matches = nothing
set objRegEx = nothing
newscustomtag = mstr
end function
end class
function processcustomtag(byval scontent)
dim objRegEx,match,matches
set objRegEx = new RegExp
objRegEx.pattern = "{ncms:[^<>]+?\/}"
objRegEx.ignorecase = true
objRegEx.global = true
set matches = objRegEx.execute(scontent)
for each match in matches
scontent = replace(scontent,match.value,parsetag(match.value))
next
set matches = nothing
set objRegEx = nothing
processcustomtag = scontent
end function
function X_processcustomtag(byval scontent)
dim objRegEx,match,matches
set objRegEx = new RegExp
objRegEx.pattern = "(\[ncms:).+?(\])(.|\n)+?(\[\/ncms\])"
objRegEx.ignorecase = true
objRegEx.global = true
set matches = objRegEx.execute(scontent)
for each match in matches
scontent = replace(scontent,match.value,parsetag(match.value))
next
set matches = nothing
set objRegEx = nothing
X_processcustomtag = scontent
end function
function getattribute(byval strattribute,byval strtag)
dim objRegEx,matches
set objRegEx = new RegExp
objRegEx.pattern = lcase(strattribute)&"=""[0-9a-zA-Z]*"""
objRegEx.ignorecase = true
objRegEx.global = true
set matches = objRegEx.execute(strtag)
if matches.count > 0 then
getattribute = split(matches(0).value,"""")(1)
else
getattribute = ""
end if
set matches = nothing
set objRegEx = nothing
end function
function getinnerhtml(byval strhtml)
dim objregex,matches,str
set objregex = new regexp
objregex.pattern = "(\])(.|\n)+?(\[\/ncms\])"
objregex.ignorecase = true
objregex.global = false
set matches = objregex.execute(strhtml)
if matches.count > 0 then
str = trim(matches.item(0).value)
end if
set matches = nothing
if len(str) > 8 then
getinnerhtml = mid(str,2,len(str) - 8)
end if
end function
function parsetag(byval strtag)
dim arrresult,classname,arrattributes,objclass
if len(strtag) = 0 then exit function
arrresult = split(strtag,":")
classname = split(arrresult(1)," ")(0)
select case lcase(classname)
case "news"
set objclass = new ncmsnewstag
if not isnumeric(getattribute("id",strtag)) then
response.write("标签[ncms:news]参数错误!参数[id]必须是数字!")
response.end()
end if
objclass.id = getattribute("id",strtag)
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[ncms:news]参数错误!参数[num]必须是数字!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[ncms:news]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
objclass.show = getattribute("show",strtag)
if getattribute("lih",strtag) <> "" and not isnumeric(getattribute("lih",strtag)) then
response.write("标签[ncms:news]参数错误!参数[lih]必须是数字!")
response.end()
end if
objclass.lih = getattribute("lih",strtag)
if getattribute("imgw",strtag) <> "" and not isnumeric(getattribute("imgw",strtag)) then
response.write("标签[ncms:news]参数错误!参数[imgw]必须是数字!")
response.end()
end if
objclass.imgw = getattribute("imgw",strtag)
if getattribute("imgh",strtag) <> "" and not isnumeric(getattribute("imgh",strtag)) then
response.write("标签[ncms:news]参数错误!参数[imgh]必须是数字!")
response.end()
end if
objclass.imgh = getattribute("imgh",strtag)
if getattribute("tgt",strtag) <> "" and getattribute("tgt",strtag) <> "blank" then
response.write("标签[ncms:news]参数错误!参数[tgt]必须是[<font color=""red"">blank</font>]!")
response.end()
end if
objclass.tgt = getattribute("tgt",strtag)
if getattribute("hit",strtag) <> "" and not isnumeric(getattribute("hit",strtag)) then
response.write("标签[ncms:free]参数错误!参数[hit]必须是数字!")
response.end()
end if
objclass.hit = getattribute("hit",strtag)
if not isnumeric(getattribute("col",strtag)) then
response.write("标签[ncms:news]参数错误!参数[col]必须是数字!")
response.end()
end if
parsetag = objclass.newsshow(getattribute("ty",strtag),getattribute("col",strtag))
set objclass = nothing
case "free"
set objclass = new X_ncmsnewstag
if not isnumeric(getattribute("id",strtag)) then
response.write("标签[ncms:free]参数错误!参数[id]必须是数字!")
response.end()
end if
objclass.id = getattribute("id",strtag)
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[ncms:free]参数错误!参数[num]必须是数字!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[news:free]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
objclass.show = getattribute("show",strtag)
if getattribute("lih",strtag) <> "" and not isnumeric(getattribute("lih",strtag)) then
response.write("标签[ncms:free]参数错误!参数[lih]必须是数字!")
response.end()
end if
objclass.lih = getattribute("lih",strtag)
if getattribute("hit",strtag) <> "" and not isnumeric(getattribute("hit",strtag)) then
response.write("标签[ncms:free]参数错误!参数[hit]必须是数字!")
response.end()
end if
objclass.hit = getattribute("hit",strtag)
if not isnumeric(getattribute("col",strtag)) then
response.write("标签[ncms:free]参数错误!参数[col]必须是数字!")
response.end()
end if
parsetag = objclass.newsshow(getattribute("ty",strtag),getattribute("col",strtag),getinnerhtml(strtag))
case "menu"
set objclass = new ncmsmenutag
parsetag = objclass.menushow(getattribute("show",strtag))
set objclass = nothing
case "info"
set objclass = new ncmsinfotag
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[ncms:info]参数错误!参数[num]必须是数字!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[ncms:info]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
parsetag = objclass.infoshow()
set objclass = nothing
case "head"
set objclass = new ncmsheadtag
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[ncms:head]参数错误!参数[num]必须是数字!")
response.end()
elseif getattribute("num",strtag) > 6 then
response.write("标签[ncms:head]参数错误!参数[num]在[1-6]之间!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[ncms:head]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
if getattribute("imgw",strtag) <> "" and not isnumeric(getattribute("imgw",strtag)) then
response.write("标签[ncms:head]参数错误!参数[imgw]必须是数字!")
response.end()
end if
objclass.imgw = getattribute("imgw",strtag)
if getattribute("imgh",strtag) <> "" and not isnumeric(getattribute("imgh",strtag)) then
response.write("标签[ncms:head]参数错误!参数[imgh]必须是数字!")
response.end()
end if
objclass.imgh = getattribute("imgh",strtag)
if getattribute("size",strtag) <> "" and not isnumeric(getattribute("size",strtag)) then
response.write("标签[ncms:head]参数错误!参数[size]必须是数字!")
response.end()
end if
objclass.size = getattribute("size",strtag)
parsetag = objclass.headshow(getattribute("ty",strtag))
set objclass = nothing
case "link"
set objclass = new ncmslinktag
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[ncms:link]参数错误!参数[num]必须是数字!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("col",strtag)) then
response.write("标签[ncms:link]参数错误!参数[col]必须是数字!")
response.end()
end if
parsetag = objclass.linkshow(getattribute("ty",strtag),getattribute("col",strtag))
set objclass = nothing
case else
response.write("标签[ncms:xxx]构造错误!")
response.end()
end select
end function
function parseclasstag(byval strtag,byval classid,byval indexid,byval pagestr)
dim arrresult,classname,arrattributes,objclass
if len(strtag) = 0 then exit function
arrresult = split(strtag,":")
classname = split(arrresult(1)," ")(0)
select case lcase(classname)
case "list"
set objclass = new ncmsclasstag
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[news:list]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
objclass.order = getattribute("order",strtag)
if getattribute("lih",strtag) <> "" and not isnumeric(getattribute("lih",strtag)) then
response.write("标签[news:list]参数错误!参数[lih]必须是数字!")
response.end()
end if
objclass.lih = getattribute("lih",strtag)
if not isnumeric(getattribute("col",strtag)) then
response.write("标签[news:list]参数错误!参数[col]必须是数字!")
response.end()
end if
parseclasstag = objclass.classshow(getattribute("ty",strtag),getattribute("col",strtag),classid,indexid,pagestr)
set objclass = nothing
case else
response.write("标签[news:xxxx]构造错误!")
response.end()
end select
end function
function parsenewstag(byval strtag,byval classid,byval newsid,byval keywords)
dim arrresult,classname,arrattributes,objclass
if len(strtag) = 0 then exit function
arrresult = split(strtag,":")
classname = split(arrresult(1)," ")(0)
select case lcase(classname)
case "relate"
set objclass = new ncmsrelatetag
if not isnumeric(getattribute("num",strtag)) then
response.write("标签[news:relate]参数错误!参数[num]必须是数字!")
response.end()
end if
objclass.num = getattribute("num",strtag)
if not isnumeric(getattribute("len",strtag)) then
response.write("标签[news:relate]参数错误!参数[len]必须是数字!")
response.end()
end if
objclass.len = getattribute("len",strtag)
if getattribute("lih",strtag) <> "" and not isnumeric(getattribute("lih",strtag)) then
response.write("标签[news:relate]参数错误!参数[lih]必须是数字!")
response.end()
end if
objclass.lih = getattribute("lih",strtag)
if not isnumeric(getattribute("col",strtag)) then
response.write("标签[news:relate]参数错误!参数[col]必须是数字!")
response.end()
end if
parsenewstag = objclass.relateshow(getattribute("col",strtag),classid,newsid,keywords)
set objclass = nothing
case "page"
set objclass = new ncmspagetag
parsenewstag = objclass.pageshow(getattribute("show",strtag),classid,newsid)
set objclass = nothing
case else
response.write("标签[news:xxxx]构造错误!")
response.end()
end select
end function
function getcurclasscount(classid)
dim rs,curclasscount
set rs = conn.execute("select count(*) from NCMS_news where classid in(" & classid & allchildclass(classid) & ")")
if instr(rs(0)/n_listnum,".") <> 0 then
curclasscount = fix(rs(0)/n_listnum) + 1
else
curclasscount = rs(0)/n_listnum
end if
rs.close:set rs = nothing
getcurclasscount = curclasscount
end function
class ncmsclasstag
public ty,len,order,lih
public function classshow(stype,scolumn,classid,indexid,pagestr)
dim TempHTM,xsql,rs,sql,databox,l,obox
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
if indexid = "" or indexid = 0 then
indexid = 1
end if
select case stype
case "text"
set rs = server.createobject("adodb.recordset")
if order = "desc" then
sql = "select classid,title,click,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and created=1 and pagetype=0 order by id desc"
elseif order = "asc" then
sql = "select classid,title,click,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and created=1 and pagetype=0 order by id asc"
else
response.write("标签[news:list]参数[order]错误!")
response.end()
end if
rs.cursorlocation = 3
rs.open sql,conn,1,3
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
classshow = TempHTM
exit function
end if
rs.pagesize = n_listnum
rs.absolutepage = indexid
for l = 1 to rs.pagesize
if rs.eof then exit for
TempHTM = TempHTM & "<td height=""" & lih & """ align=""left"" valign=""middle"">·<a href=""" & site_root & "/" & site_html & "/" & getclasspath(rs("classid")) & "/" & rs("filename") & site_extname & """ title=""" & rs("title") & """>" & gottopic(rs("title"),len) & "</a></td>" & chr(10)
TempHTM = TempHTM & "<td height=""" & lih & """ align=""center"" valign=""middle"">" & rs("click") & "</td>" & chr(10)
TempHTM = TempHTM & "<td height=""" & lih & """ align=""center"" valign=""middle"">" & rs("addtime") & "</td>" & chr(10)
if l = rs.pagesize then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint(l mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
rs.movenext
next
rs.close:set rs = nothing
TempHTM = TempHTM & "</table>" & chr(10)
classshow = TempHTM & pagestr
case "image"
if IsObjInstalled("persits.jpeg") = true and jpeg_gate = 0 then
set rs = server.createobject("adodb.recordset")
if order = "desc" then
sql = "select classid,title,bimg,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and isimg=1 and created=1 and pagetype=0 order by id desc"
elseif order = "asc" then
sql = "select classid,title,bimg,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and isimg=1 and created=1 and pagetype=0 order by id asc"
else
response.write("标签[news:list]参数[order]错误!")
response.end()
end if
rs.cursorlocation = 3
rs.open sql,conn,1,3
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
classshow = TempHTM
exit function
end if
rs.pagesize = n_listnum
rs.absolutepage = indexid
for l = 1 to rs.pagesize
if rs.eof then exit for
TempHTM = TempHTM & "<td><div id=""simg""><a href=""" & site_root & "/" & site_html & "/" & getclasspath(rs("classid")) & "/" & rs("filename") & site_extname & """><img height=""" & jpeg_height & """ src=""" & site_root & "/" & site_upload & "/" & site_simg & "/" & rs("bimg") & """ width=""" & jpeg_width & """ alt=""" & rs("title") & """ /></a></div></td>" & chr(10)
if l = rs.pagesize then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint(l mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
if checkfile("" & site_root & "/" & site_upload & "/" & site_bimg & "/" & rs("bimg") & "") = true then
set obox = server.createobject("persits.jpeg")
obox.open server.mappath("" & site_root & "/" & site_upload & "/" & site_bimg & "/" & rs("bimg") & "")
obox.width = jpeg_width
obox.height = jpeg_height
obox.save server.mappath("" & site_root & "/" & site_upload & "/" & site_simg & "/" & rs("bimg") & "")
set obox = nothing
end if
rs.movenext
next
rs.close:set rs = nothing
TempHTM = TempHTM & "</table>" & chr(10)
classshow = TempHTM & pagestr
else
set rs = server.createobject("adodb.recordset")
if order = "desc" then
sql = "select classid,title,bimg,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and isimg=1 and created=1 and pagetype=0 order by id desc"
elseif order = "asc" then
sql = "select classid,title,bimg,filename,addtime from NCMS_news where classid in(" & classid & allchildclass(classid) & ") and isimg=1 and created=1 and pagetype=0 order by id asc"
else
response.write("标签[news:list]参数[order]错误!")
response.end()
end if
rs.cursorlocation = 3
rs.open sql,conn,1,3
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
classshow = TempHTM
exit function
end if
rs.pagesize = n_listnum
rs.absolutepage = indexid
for l = 1 to rs.pagesize
if rs.eof then exit for
TempHTM = TempHTM & "<td><div id=""simg""><a href=""" & site_root & "/" & site_html & "/" & getclasspath(rs("classid")) & "/" & rs("filename") & site_extname & """><img height=""" & jpeg_height & """ src=""" & site_root & "/" & site_upload & "/" & site_bimg & "/" & rs("bimg") & """ width=""" & jpeg_width & """ alt=""" & rs("title") & """ /></a></div></td>" & chr(10)
if l = rs.pagesize then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint(l mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
rs.movenext
next
rs.close:set rs = nothing
TempHTM = TempHTM & "</table>" & chr(10)
classshow = TempHTM & pagestr
end if
case else
response.write("标签[news:list]参数[ty]错误!")
response.end()
end select
end function
end class
class ncmsnewstag
public id,ty,show,len,num,lih,imgw,imgh,tgt,hit
public function newsshow(stype,scolumn)
dim TempHTM,xsql,rs,databox,i,imgdot,obox
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
if tgt = "" then
tgt = "self"
end if
select case stype
case "text"
if show = "new" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and created=1 and pagetype=0 order by id desc")
end if
elseif show = "elite" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where elite=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "hot" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where click>=" & hit & " and created=1 and pagetype=0 order by click desc")
else
set rs = conn.execute("select top " & num & " classid,title,isimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=" & hit & " and created=1 and pagetype=0 order by click desc")
end if
else
response.write("标签[ncms:news]参数[show]错误!")
response.end()
end if
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
newsshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
if databox(2,i) = 1 and show = "new" then
imgdot = "[<font color=""red"" size=""2"">图</font>]"
else
imgdot = ""
end if
TempHTM = TempHTM & "<td height=""" & lih & """ align=""left"" valign=""middle"">·<a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(3,i) & site_extname & """ title=""" & databox(1,i) & """ target=""_" & tgt & """>" & gottopic(databox(1,i),len) & imgdot & "</a></td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
next
databox = ""
TempHTM = TempHTM & "</table>" & chr(10)
newsshow = TempHTM
end if
case "image"
if IsObjInstalled("persits.jpeg") = true and jpeg_gate = 0 then
if show = "new" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "elite" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where elite=1 and isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "hot" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where click>=" & hit & " and isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,simg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=" & hit & " and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
else
response.write("标签[ncms:news]参数[show]错误!")
response.end()
end if
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
newsshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td>" & chr(10)
TempHTM = TempHTM & "<div id=""simg""><a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(4,i) & site_extname & """ target=""_" & tgt & """><img src=""" & site_root & "/" & site_upload & "/" & site_simg & "/" & databox(2,i) & """ alt=""" & databox(1,i) & """ /><br />" & gottopic(databox(1,i),len) & "</a></div>" & chr(10)
TempHTM = TempHTM & "</td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
if checkfile("" & site_root & "/" & site_upload & "/" & site_bimg & "/" & databox(2,i) & "") = true then
set obox = server.createobject("persits.jpeg")
obox.open server.mappath("" & site_root & "/" & site_upload & "/" & site_bimg & "/" & databox(2,i) & "")
if imgw = "" or imgh = "" then
obox.width = jpeg_width
obox.height = jpeg_height
else
obox.width = imgw
obox.height = imgh
end if
obox.save server.mappath("" & site_root & "/" & site_upload & "/" & site_simg & "/" & databox(3,i) & "")
set obox = nothing
end if
next
databox = ""
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "</table>" & chr(10)
newsshow = TempHTM
end if
else
if show = "new" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "elite" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where elite=1 and isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "hot" then
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where click>=" & hit & " and isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=" & hit & " and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
else
response.write("标签[ncms:news]参数[show]错误!")
response.end()
end if
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
newsshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td><div id=""simg""><a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(3,i) & site_extname & """ target=""_" & tgt & """><img height=""" & jpeg_height & """ src=""" & site_root & "/" & site_upload & "/" & site_bimg & "/" & databox(2,i) & """ width=""" & jpeg_width & """ alt=""" & databox(1,i) & """ /></a></div></td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
next
databox = ""
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "</table>" & chr(10)
newsshow = TempHTM
end if
end if
case else
response.write("标签[ncms:news]参数[ty]错误!")
response.end()
end select
end function
end class
class ncmsinfotag
public len,num
public function infoshow()
dim TempHTM,rs,databox,i
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
set rs = conn.execute("select top " & num & " content,addtime from NCMS_info order by addtime desc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有公告信息!</font></li>"
infoshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td>" & gottopic(databox(0,i),len) & "(" & databox(1,i) & ")</td>" & chr(10)
next
databox = ""
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "</table>" & chr(10)
infoshow = TempHTM
end if
end function
end class
class ncmsheadtag
public ty,len,num,imgw,imgh,size
public function headshow(stype)
dim rs,databox,TempHTM,i,NcmsP,NcmsL,NcmsT,tempstr:tempstr = "|"
select case stype
case "text"
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
set rs = conn.execute("select top " & num & " id,classid,title,content,filename from NCMS_news where head=1 and isimg=0 and created=1 and pagetype=0 order by id desc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有头条新闻!</font></li>"
headshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<tr><td><a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(1,i)) & "/" & databox(4,i) & site_extname & """ target=""_blank""><font size=""" & size & """><b>" & databox(2,i) & "</b></font></a></td></tr>" & chr(10)
TempHTM = TempHTM & "<tr><td>" & gottopic(LoseHtml(databox(3,i)),len) & "[<a href=""" & site_root & "/tools/comment.asp?newsid=" & databox(0,i) & "&newstitle=" & getnewstitle(databox(0,i)) & "#comment"" target=""_blank"" title=""评论""><font color=""red"" size=""2"">评论</font></a>]</td></tr>" & chr(10)
next
databox = ""
TempHTM = TempHTM & "</table>" & chr(10)
headshow = TempHTM
end if
case "image"
set rs = conn.execute("select top " & num & " classid,title,bimg,filename from NCMS_news where head=1 and isimg=1 and created=1 and pagetype=0 order by id desc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有头条新闻!</font></li>"
headshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
NcmsP = NcmsP & "" & site_root & "/" & site_upload & "/" & site_bimg & "/" & databox(2,i) & tempstr & ""
NcmsL = NcmsL & "" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(3,i) & site_extname & tempstr & ""
NcmsT = NcmsT & "" & gottopic(databox(1,i),len) & tempstr & ""
next
databox = ""
TempHTM = TempHTM & "" & chr(10) & "<script language=""JavaScript"" type=""text/javascript"">" & chr(10)
TempHTM = TempHTM & "<!--" & chr(10)
TempHTM = TempHTM & "var NcmsPW = " & imgw & "" & chr(10)
TempHTM = TempHTM & "var NcmsPH = " & imgh & "" & chr(10)
TempHTM = TempHTM & "var NcmsTH = 0" & chr(10)
TempHTM = TempHTM & "var NcmsAH = NcmsPH + NcmsTH" & chr(10)
TempHTM = TempHTM & "var NcmsP = '" & left(NcmsP,strlength(NcmsP) - 1) & "'" & chr(10)
TempHTM = TempHTM & "var NcmsL = '" & left(NcmsL,strlength(NcmsL) - 1) & "'" & chr(10)
TempHTM = TempHTM & "var NcmsT = '" & left(NcmsT,strlength(NcmsT) - 1) & "'" & chr(10)
TempHTM = TempHTM & "document.write('<object classid=""clsid:d27cdb6e-ae6d-11cf-96b8-444553540000"" codebase=""http://fpdownload.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=6,0,0,0"" width=""'+NcmsPW+'"" height=""'+NcmsAH+'"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""allowScriptAccess"" value=""sameDomain"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""movie"" value=""" & site_root & "/images/ncms/head.swf"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""quality"" value=""high"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""bgcolor"" value=""#252f3c"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""menu"" value=""false"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""wmode"" value=""opaque"">');" & chr(10)
TempHTM = TempHTM & "document.write('<param name=""FlashVars"" value=""pics='+NcmsP+'&links='+NcmsL+'&texts='+NcmsT+'&borderwidth='+NcmsPW+'&borderheight='+NcmsPH+'&NcmsTHeight='+NcmsTH+'"">');" & chr(10)
TempHTM = TempHTM & "document.write('<embed src=""" & site_root & "/images/ncms/head.swf"" wmode=""opaque"" FlashVars=""pics='+NcmsP+'&links='+NcmsL+'&texts='+NcmsT+'&borderwidth='+NcmsPW+'&borderheight='+NcmsPH+'&NcmsTHeight='+NcmsTH+'"" menu=""false"" bgcolor=""#252f3c"" quality=""high"" width=""'+NcmsPW+'"" height=""'+NcmsAH+'"" allowScriptAccess=""sameDomain"" type=""application/x-shockwave-flash"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" />');" & chr(10)
TempHTM = TempHTM & "document.write('</object>');" & chr(10)
TempHTM = TempHTM & "//-->" & chr(10)
TempHTM = TempHTM & "</script>" & chr(10)
headshow = TempHTM
end if
case else
response.write("标签[ncms:head]参数[ty]错误!")
response.end()
end select
end function
end class
class ncmslinktag
public num,ty
public function linkshow(stype,scolumn)
dim TempHTM,rs,databox,i
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
select case stype
case "text"
set rs = conn.execute("select top " & num & " name,site from NCMS_link where kinds=0 order by orders asc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有文字连接!</font></li>"
linkshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td><a href=""" & databox(1,i) & """ title=""" & databox(0,i) & """ target=""_blank"">" & databox(0,i) & "</a></td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
next
databox = ""
TempHTM = TempHTM & "</table>" & chr(10)
linkshow = TempHTM
end if
case "image"
set rs = conn.execute("select top " & num & " name,site,logo from NCMS_link where kinds=1 order by orders asc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有图片连接!</font></li>"
linkshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td><a href=""" & databox(1,i) & """ target=""_blank""><img src=""" & databox(2,i) & """ alt=""" & databox(0,i) & """ /></a></td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
next
databox = ""
TempHTM = TempHTM & "</table>" & chr(10)
linkshow = TempHTM
end if
case else
response.write("标签[ncms:link]参数[ty]错误!")
response.end()
end select
end function
end class
class ncmsmenutag
public show
public function menushow(stype)
dim TempHTM,rs,databox,i,tempstr:tempstr = " | "
select case stype
case "center"
TempHTM = "" & chr(10) & "<div id=""navbox"">" & chr(10)
TempHTM = TempHTM & "<ul id=""nav"">" & chr(10)
set rs = conn.execute("select id,cname,ename,isout,isurl,link from NCMS_class where parent=0 and kinds=1 order by orders asc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = ""
menushow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
end if
for i = 0 to ubound(databox,2)
if databox(4,i) = 0 then
TempHTM = TempHTM & "<li><a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/index" & site_extname & """ title=""" & databox(1,i) & """>" & databox(1,i) & "</a>" & childmenushow(databox(0,i)) & "</li>" & chr(10)
elseif databox(3,i) = 1 then
if databox(4,i) = 0 then
TempHTM = TempHTM & "<li><a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/" & databox(5,i) & """ title=""" & databox(1,i) & """>" & databox(1,i) & "</a>" & childmenushow(databox(0,i)) & "</li>" & chr(10)
elseif databox(4,i) = 1 then
TempHTM = TempHTM & "<li><a href=""" & databox(5,i) & """ title=""" & databox(1,i) & """>" & databox(1,i) & "</a></li>" & chr(10)
end if
end if
next:databox = ""
TempHTM = TempHTM & "</ul>" & chr(10)
TempHTM = TempHTM & "</div>" & chr(10)
menushow = TempHTM
case "top"
set rs = conn.execute("select id,cname,ename,isout,isurl,link from NCMS_class where parent=0 and kinds=2 order by orders asc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = ""
menushow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
if i = ubound(databox,2) then tempstr = ""
if databox(3,i) = 0 then
TempHTM = TempHTM & "<a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/index" & site_extname & """>" & databox(1,i) & "</a>" & tempstr & ""
elseif databox(3,i) = 1 then
if databox(4,i) = 0 then
TempHTM = TempHTM & "<a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/" & databox(5,i) & """>" & databox(1,i) & "</a>" & tempstr & ""
elseif databox(4,i) = 1 then
TempHTM = TempHTM & "<a href=""" & databox(5,i) & """>" & databox(1,i) & "</a>" & tempstr & ""
end if
end if
next
menushow = TempHTM
end if
case "bottom"
set rs = conn.execute("select id,cname,ename,isout,isurl,link from NCMS_class where parent=0 and kinds=3 order by orders asc")
if rs.eof then
rs.close:set rs = nothing
TempHTM = ""
menushow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
if i = ubound(databox,2) then tempstr = ""
if databox(3,i) = 0 then
TempHTM = TempHTM & "<a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/"">" & databox(1,i) & "</a>" & tempstr & ""
elseif databox(3,i) = 1 then
if databox(4,i) = 0 then
TempHTM = TempHTM & "<a href=""" & site_root & "/" & site_html & "/" & databox(2,i) & "/" & databox(5,i) & """>" & databox(1,i) & "</a>" & tempstr & ""
elseif databox(4,i) = 1 then
TempHTM = TempHTM & "<a href=""" & databox(5,i) & """>" & databox(1,i) & "</a>" & tempstr & ""
end if
end if
next
menushow = TempHTM
end if
case else
response.write("标签[ncms:menu]参数[show]错误!")
response.end()
end select
end function
private function childmenushow(id)
dim TempHTM,rschild,box,j
TempHTM = "" & chr(10) & "<ul>" & chr(10)
set rschild = conn.execute("select id,cname,ename,isout,isurl,link from NCMS_class where parent=" & id & " and kinds=1 order by orders asc")
if rschild.eof then
rschild.close:set rschild = nothing
TempHTM = ""
childmenushow = TempHTM
exit function
else
box = rschild.getrows()
rschild.close:set rschild = nothing
end if
for j = 0 to ubound(box,2)
if box(3,j) = 0 then
TempHTM = TempHTM & "<li><a href=""" & site_root & "/" & site_html & "/" & box(2,j) & "/"" title=""" & box(1,j) & """>" & box(1,j) & "</a></li>" & chr(10)
elseif box(3,j) = 1 then
if box(4,j) = 0 then
TempHTM = TempHTM & "<li><a href=""" & site_root & "/" & site_html & "/" & box(2,j) & "/" & box(5,j) & """ title=""" & box(1,j) & """>" & box(1,j) & "</a></li>" & chr(10)
elseif box(4,j) = 1 then
TempHTM = TempHTM & "<li><a href=""" & box(5,j) & """ title=""" & box(1,j) & """>" & box(1,j) & "</a></li>" & chr(10)
end if
end if
next:box = ""
TempHTM = TempHTM & "</ul>" & chr(10)
childmenushow = TempHTM
end function
end class
class ncmsrelatetag
public len,num,lih
public function relateshow(scolumn,classid,newsid,keywords)
if keywords = "" or isnull(keywords) then
relateshow = "<li><font color=""red"">暂时没有相关新闻!</font></li>"
exit function
end if
dim arr,i,TempSql
arr = split(keywords,",",3,1)
for i = 0 to ubound(arr)
if TempSql <> "" then
TempSql = TempSql & "or title like '%" & arr(i) & "%' or keywords like '%" & arr(i) & "%'"
else
TempSql = TempSql & "title like '%" & arr(i) & "%' or keywords like '%" & arr(i) & "%'"
end if
next
if TempSql <> "" then
TempSql = "where (" & TempSql & ") and classid=" & classid & " and id <> " & newsid & " order by id desc"
end if
dim TempHTM:TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
dim rs,databox,j
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news " & TempSql)
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有相关新闻!</font></li>"
relateshow = TempHTM
else
databox = rs.getrows()
rs.close:set rs = nothing
for j = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td height=""" & lih & """ align=""left"" valign=""middle"">·<a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,j)) & "/" & databox(2,j) & site_extname & """ title=""" & databox(1,j) & """ target=""_blank"">" & gottopic(databox(1,j),len) & "</a></td>" & chr(10)
if j = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((j+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
next
TempHTM = TempHTM & "</table>" & chr(10)
relateshow = TempHTM
end if
end function
end class
class ncmspagetag
public show
public function pageshow(stype,classid,newsid)
dim TempHTM,rs,databox
TempHTM = "" & chr(10) & "<div id=""page"">"
select case stype
case "last"
set rs = conn.execute("select top 1 id,classid,title,filename from NCMS_news where classid=" & classid & " and id > " & newsid & "")
if rs.eof or rs.bof then
rs.close:set rs = nothing
TempHTM = TempHTM & "上一篇：<font color=""red"">没有上一篇</font>"
TempHTM = TempHTM & "</div>" & chr(10)
pageshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
TempHTM = TempHTM & "上一篇：<a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(1,0)) & "/" & databox(3,0) & site_extname & """>" & databox(2,0) & "</a>"
TempHTM = TempHTM & "</div>" & chr(10)
databox = ""
pageshow = TempHTM
end if
case "next"
set rs = conn.execute("select top 1 id,classid,title,filename from NCMS_news where classid=" & classid & " and id < " & newsid & " order by id desc")
if rs.eof or rs.bof then
rs.close:set rs = nothing
TempHTM = TempHTM & "下一篇：<font color=""red"">没有下一篇</font>"
TempHTM = TempHTM & "</div>" & chr(10)
pageshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
TempHTM = TempHTM & "下一篇：<a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(1,0)) & "/" & databox(3,0) & site_extname & """>" & databox(2,0) & "</a>"
TempHTM = TempHTM & "</div>" & chr(10)
databox = ""
pageshow = TempHTM
end if
case else
response.write("标签[news:page]参数[show]错误!")
response.end()
end select
end function
end class
class X_ncmsnewstag
public id,ty,show,len,num,lih,hit
public function newsshow(stype,scolumn,strHtml)
dim TempHTM,xsql,rs,databox,i
TempHTM = "" & chr(10) & "<table cellpadding=""0"" cellspacing=""0"" width=""100%"" border=""0"">" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
select case stype
case "text"
if show = "new" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and created=1 and pagetype=0 order by id desc")
end if
elseif show = "elite" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where elite=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "hot" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where click>=" & hit & " and created=1 and pagetype=0 order by click desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=" & hit & " and created=1 and pagetype=0 order by click desc")
end if
else
response.write("标签[ncms:free]参数[show]错误!")
response.end()
end if
case "image"
if show = "new" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where isimg=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and isimg=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "elite" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where isimg=1 and elite=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and isimg=1 and elite=1 and created=1 and pagetype=0 order by id desc")
end if
elseif show = "hot" then
if id = 0 then
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where isimg=1 and click>=" & hit & " and created=1 and pagetype=0 order by click desc")
else
set rs = conn.execute("select top " & num & " id,classid,title,content,click,isimg,bimg,simg,filename,addtime from NCMS_news where classid in(" & id & allchildclass(id) & ") and isimg=1 and click>=" & hit & " and created=1 and pagetype=0 order by click desc")
end if
else
response.write("标签[ncms:free]参数[show]错误!")
response.end()
end if
case else
response.write("标签[ncms:free]参数[ty]错误!")
response.end()
end select
if rs.eof then
rs.close:set rs = nothing
TempHTM = "<li><font color=""red"">暂时没有新闻!</font></li>"
newsshow = TempHTM
exit function
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "<td height=""" & lih & """ align=""left"" valign=""middle"">" & strHtml & "</td>" & chr(10)
if i = ubound(databox,2) then
TempHTM = TempHTM & "</tr>" & chr(10)
else
if cint((i+1) mod scolumn) = 0 then
TempHTM = TempHTM & "</tr>" & chr(10)
TempHTM = TempHTM & "<tr>" & chr(10)
end if
end if
dim charclass,PatrnStr
set charclass = new stringclass
PatrnStr = "\{\$classname\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,"<a href=""" & site_root & "/" & site_html & "/" & getclasspath(databox(1,i)) & "/index" & site_extname & """ target=""_blank"">" & getclassname(databox(1,i)) & "</a>")
PatrnStr = "\{\$title\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,gottopic(LoseHtml(databox(2,i)),len))
PatrnStr = "\{\$content\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,gottopic(LoseHtml(databox(3,i)),len))
PatrnStr = "\{\$click\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,databox(4,i))
PatrnStr = "\{\$filepath\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,"" & site_root & "/" & site_html & "/" & getclasspath(databox(1,i)) & "/" & databox(8,i) & site_extname & "")
PatrnStr = "\{\$addtime\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,formattagdate(databox(9,i),datestyle))
PatrnStr = "\{\$imgpath\$\}"
if IsObjInstalled("persits.jpeg") = true and jpeg_gate = 0 then
TempHTM = charclass.replacestr(PatrnStr,TempHTM,"" & site_root & "/" & site_upload & "/" & site_simg & "/" & databox(7,i) & "")
else
TempHTM = charclass.replacestr(PatrnStr,TempHTM,"" & site_root & "/" & site_upload & "/" & site_bimg & "/" & databox(6,i) & "")
end if
PatrnStr = "\{\$comment\$\}"
TempHTM = charclass.replacestr(PatrnStr,TempHTM,"[<a href=""" & site_root & "/tools/comment.asp?newsid=" & databox(0,i) & "&newstitle=" & getnewstitle(databox(0,i)) & "#comment"" target=""_blank"" title=""评论""><font color=""red"" size=""2"">评论</font></a>]")
next
databox = ""
TempHTM = TempHTM & "</table>" & chr(10)
newsshow = TempHTM
end if
end function
end class
function guide(id)
dim TempHTM
if id = "" or len(id) = 0 or not isnumeric(id) then
TempHTM = "当前位置 : <a href=""" & site_root & "/index" & site_extname & """>首页</a> >>"
else
dim rs
set rs = conn.execute("select top 1 id,parent,cname,ename from NCMS_class where id=" & id)
if not rs.eof then
TempHTM = TempHTM & guide(rs("parent"))
TempHTM = TempHTM & "<a href=""" & site_root & "/" & site_html & "/" & rs("ename") & "/index" & site_extname & """>" & rs("cname") & "</a> >> "
end if
rs.close:set rs = nothing
if id = 0 then
TempHTM = TempHTM & "当前位置 : <a href=""" & site_root & "/index" & site_extname & """>首页</a> >> "
end if
end if
guide = TempHTM
end function
function createindex()
dim Temp:Temp = ""
Temp = processcustomtag(loadtempletfile("../templet/" & site_dtemp & ""))
Temp = X_processcustomtag(Temp)
dim charclass
set charclass = new stringclass
dim PatrnStr
PatrnStr = "<title>.*?</title>"
Temp = charclass.replacestr(PatrnStr,Temp,"<title>" & site_name & "</title>")
PatrnStr = "\{\$guide\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,guide(""))
PatrnStr = "\{\$keywords\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_keywords)
PatrnStr = "\{\$search\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,search())
PatrnStr = "\{\$description\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_description)
PatrnStr = "\{\$copyright\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_copyright)
PatrnStr = "\{\$root\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_root)
dim sPATH:sPATH = "" & site_root & "/index" & site_extname & ""
dim objstream
set objstream = server.createobject("adodb.stream")
with objstream
.open
.charset = "" & chrset & ""
.position = objstream.size
.writetext = Temp
.savetofile server.mappath(sPATH),2
.close
end with
set objstream = nothing
if err.number <> 0 then
err.clear
createindex = false
else
createindex = true
end if
end function
function createnewsclass(id)
dim arrcont:arrcont = getcurclasscount(id)
dim i,j
for i = 0 to arrcont - 1
dim Temp:Temp = ""
Temp = processcustomtag(loadtempletfile("../templet/" & getclassall(id,1) & ""))
Temp = X_processcustomtag(Temp)
dim charclass
set charclass = new stringclass
dim PatrnStr
PatrnStr = "<title>.*?</title>"
Temp = charclass.replacestr(PatrnStr,Temp,"<title>" & charclass.getstr(getclassname(id)) & " - " & site_name & "</title>")
PatrnStr = "\{\$guide\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,guide(id))
PatrnStr = "\{\$keywords\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_keywords)
PatrnStr = "\{\$search\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,search())
PatrnStr = "\{\$description\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_description)
PatrnStr = "\{\$copyright\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_copyright)
PatrnStr = "\{\$root\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_root)
dim sPATH,cPATH:cPATH = "" & site_root & "/" & site_html & "/" & getclasspath(id) & "/"
createdir(server.mappath(cPATH))
dim PageHTM:PageHTM = ""
if i = 0 then
sPATH = "" & cPATH & "index" & site_extname & ""
else
sPATH = "" & cPATH & "index" & site_extname & ""
sPATH = left(sPATH,(len(sPATH)-len(site_extname))) & "_" & i + 1 & site_extname
end if
if arrcont >= 2 then
if i = 0 then
PageHTM = PageHTM & "【首页】-"
PageHTM = PageHTM & "【上页】"
end if
if i > 1 then
PageHTM = PageHTM & "【<a href=""index" & site_extname & """>首页</a>】-"
PageHTM = PageHTM & "【<a href=""index" & "_" & i & site_extname & """>上页</a>】"
end if
if i = 1 Then
PageHTM = PageHTM & "【<a href=""index" & site_extname & """>首页</a>】-"
PageHTM = PageHTM & "【<a href=""index" & site_extname & """>上页</a>】"
end if
PageHTM = PageHTM & "-【第<font color=""red"">" & i + 1 & "</font>页】/【共<font color=""red"">" & arrcont & "</font>页】-"
if i < arrcont - 1 then
PageHTM = PageHTM & "【<a href=""index" & "_" & i + 2 & site_extname & """>下页</a>】-"
PageHTM = PageHTM & "【<a href=""index" & "_" & arrcont & site_extname & """>尾页</a>】- "
end if
if i = arrcont - 1 then
PageHTM = PageHTM & "【下页】-"
PageHTM = PageHTM & "【尾页】- "
end if
PageHTM = PageHTM & "<select name=""page"" onchange=""self.location.href=this.options[this.selectedIndex].value"">"
PageHTM = PageHTM & "<option selected>页/码</option>"
PageHTM = PageHTM & "<option value=""index" & site_extname & """>第1页</option>"
for j = 1 to arrcont - 1
PageHTM = PageHTM & "<option value=""index" & "_" & j + 1 & site_extname & """>第" & j + 1 & "页</option>"
next
PageHTM = PageHTM & "</select>"
end if
PatrnStr = "{news:[^<>]+?\/}"
Temp = charclass.classcustomtag(PatrnStr,Temp,id,i + 1,"<p align=""center"">" & PageHTM & "</p>" & chr(10) & "")
dim objstream
set objstream = server.createobject("adodb.stream")
with objstream
.open
.charset = "" & chrset & ""
.position = objstream.size
.writetext = Temp
.savetofile server.mappath(sPATH),2
.close
end with
next
set objstream = nothing
if err.number <> 0 then
err.clear
createnewsclass = false
else
createnewsclass = true
end if
end function
function createnewsfile(id)
dim rs,sql
set rs = server.createobject("adodb.recordset")
sql = "select id,classid,title,content,author,source,keywords,bimg,simg,filename,pagetype,addtime from NCMS_news where id=" & id
rs.open sql,conn,1,1
dim databox:databox = rs.getrows()
rs.close:set rs = nothing
dim Temp:Temp = ""
if databox(10,0) = 0 then
Temp = processcustomtag(loadtempletfile("../templet/" & getclassall(databox(1,0),2) & ""))
Temp = X_processcustomtag(Temp)
else
Temp = processcustomtag(loadtempletfile("../templet/" & site_stemp & ""))
Temp = X_processcustomtag(Temp)
end if
dim charclass
set charclass = new stringclass
dim PatrnStr,AdvCont
PatrnStr = "<title>.*?</title>"
Temp = charclass.replacestr(PatrnStr,Temp,"<title>" & charclass.getstr(databox(2,0)) & " - " & site_name & "</title>")
PatrnStr = "{news:[^<>]+?\/}"
Temp = charclass.newscustomtag(PatrnStr,Temp,databox(1,0),databox(0,0),databox(6,0))
PatrnStr = "\{\$id\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(0,0))
PatrnStr = "\{\$classid\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(1,0))
PatrnStr = "\{\$title\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(2,0))
PatrnStr = "\{\$author\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(4,0))
PatrnStr = "\{\$source\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(5,0))
PatrnStr = "\{\$keywords\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(6,0))
PatrnStr = "\{\$click\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,click(databox(0,0)))
PatrnStr = "\{\$addtime\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,databox(11,0))
PatrnStr = "\{\$guide\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,guide(databox(1,0)))
PatrnStr = "\{\$search\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,search())
PatrnStr = "\{\$fontselect\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,fontselect())
PatrnStr = "\{\$toolbar\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,toolbar(databox(0,0)))
PatrnStr = "\{\$copyurl\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,copyurl())
PatrnStr = "\{\$description\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_description)
PatrnStr = "\{\$copyright\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_copyright)
PatrnStr = "\{\$root\$\}"
Temp = charclass.replacestr(PatrnStr,Temp,site_root)
PatrnStr = "\{\$advarea\$\}"
AdvCont = databox(3,0)
AdvCont = charclass.replacestr(PatrnStr,AdvCont,advshow(site_advcode))
dim tempArr,n,sPATH,ePATH,cPATH:cPATH = "" & site_root & "/" & site_html & "/" & getclasspath(databox(1,0)) & "/"
if instr(databox(9,0),"/") = 0 then
createdir(server.mappath(cPATH))
else
tempArr = split(databox(9,0),"/")
for n = 0 to ubound(tempArr)
ePATH = replace(databox(9,0),tempArr(n),"")
next
createdir(server.mappath(cPATH & ePATH))
end if
dim TTemp:TTemp = Temp
dim arrcont:arrcont = split(AdvCont,"{$split$}",-1,1)
dim PageHTM:PageHTM = ""
dim i,j,k:k = ubound(arrcont)
for i = 0 to k
if i = 0 then
sPATH = "" & cPATH & databox(9,0) & site_extname & ""
else
sPATH = "" & cPATH & databox(9,0) & site_extname & ""
sPATH = left(sPATH,(len(sPATH)-len(site_extname))) & "_" & i + 1 & site_extname
end if
if sPATH = "" then
createnewsfile = false
exit function
end if
if k >= 1 then
PageHTM = "<p align=""center"">【本新闻共<font color=""red"">" & k + 1 & "</font>页】-"
if i = 0 then
PageHTM = PageHTM & "【首页】-"
PageHTM = PageHTM & "【上页】-"
end if
if i > 1 then
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & site_extname & """>首页</a>】-"
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & "_" & i & site_extname & """>上页</a>】-"
end if
if i = 1 Then
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & site_extname & """>首页</a>】-"
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & site_extname & """>上页</a>】-"
end if
if i < k then
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & "_" & i + 2 & site_extname & """>下页</a>】-"
PageHTM = PageHTM & "【<a href=""" & cPATH & databox(9,0) & "_" & k + 1 & site_extname & """>尾页</a>】-"
end if
if i = k then
PageHTM = PageHTM & "【下页】-"
PageHTM = PageHTM & "【尾页】-"
end if
PageHTM = PageHTM & "【当前在第<font color=""red"">" & i + 1 & "</font>页】</p>"
else
PageHTM = ""
end if
PatrnStr = "\{\$content\$\}"
Temp = charclass.replacestr(PatrnStr,TTemp,"" & chr(10) & "<div id=""content"">" & chr(10) & arrcont(i) & PageHTM & chr(10) & "</div>" & chr(10))
dim objstream
set objstream = server.createobject("adodb.stream")
with objstream
.open
.charset = "" & chrset & ""
.position = objstream.size
.writetext = X_processcustomtag(Temp)
.savetofile server.mappath(sPATH),2
.close
end with
set objstream = nothing
next
if err.number <> 0 then
err.clear
createnewsfile = false
else
conn.execute("update NCMS_news set created=1 where id=" & databox(0,0))
createnewsfile = true
databox = ""
end if
end function
function createnewsjs(show,id,len,num,lih,col,filename)
dim TempHTM,xsql,rs,databox,i
TempHTM = "document.writeln('<table cellpadding=\""0\"" cellspacing=\""0\"" width=\""100%\"" border=\""0\"">');"
TempHTM = TempHTM & "document.writeln('<tr>');"
select case show
case "new"
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and created=1 and pagetype=0 order by id desc")
end if
case "elite"
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where elite=1 and created=1 and pagetype=0 order by id desc")
else
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and created=1 and pagetype=0 order by id desc")
end if
case "hot"
if id = 0 then
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where click>=100 and created=1 and pagetype=0 order by click desc")
else
set rs = conn.execute("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=100 and created=1 and pagetype=0 order by click desc")
end if
case else
response.write("[新闻类型]参数错误!")
response.end()
end select
if rs.eof then
rs.close:set rs = nothing
TempHTM = "document.writeln('<li><font color=\""red\"">暂时没有新闻!<\/font><\/li>');"
else
databox = rs.getrows()
rs.close:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "document.writeln('<td height=\""" & lih & "\"" align=\""left\"" valign=\""middle\"">·<a href=\""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(2,i) & site_extname & "\"" title=\""" & databox(1,i) & "\"" target=\""_blank\"">" & gottopic(databox(1,i),len) & "<\/a><\/td>');"
if i = ubound(databox,2) then
TempHTM = TempHTM & "document.writeln('<\/tr>');"
else
if cint((i+1) mod col) = 0 then
TempHTM = TempHTM & "document.writeln('<\/tr>');"
TempHTM = TempHTM & "document.writeln('<tr>');"
end if
end if
next
databox = ""
TempHTM = TempHTM & "document.writeln('<\/table>');"
end if
if checkfolder("" & site_root & "/jss/") = false then
createdir(server.mappath("" & site_root & "/jss/"))
end if
if checkfile("" & site_root & "/jss/" & filename & ".js") = true then
call alertbox("文件已存在!请更换文件名!",2)
end if
dim objstream
set objstream = server.createobject("adodb.stream")
with objstream
.open
.charset = "" & chrset & ""
.position = objstream.size
.writetext = TempHTM
.savetofile server.mappath("" & site_root & "/jss/" & filename & ".js"),2
.close
end with
set objstream = nothing
if err.number <> 0 then
err.clear
createnewsjs = false
else
createnewsjs = true
end if
end function
function getnewstitle(id)
dim rs,tempstr
set rs = conn.execute("select title from NCMS_news where id=" & id)
if not rs.eof then
tempstr = server.urlencode(rs("title"))
end if
rs.close:set rs = nothing
getnewstitle = tempstr
end function
function getclasspath(id)
dim rs,tempstr
set rs = conn.execute("select ename from NCMS_class where id=" & id)
if not rs.eof then
tempstr = rs("ename")
end if
rs.close:set rs = nothing
getclasspath = tempstr
end function
function getclassid(id)
dim rs,tempstr
set rs = conn.execute("select classid from NCMS_news where id=" & id)
if not rs.eof then
tempstr = rs("classid")
end if
rs.close:set rs = nothing
getclassid = tempstr
end function
function getclassname(id)
dim rs,tempstr
set rs = conn.execute("select cname from NCMS_class where id= " & id)
if not rs.eof then
tempstr = rs("cname")
end if
rs.close:set rs = nothing
getclassname = tempstr
end function
function allchildclass(id)
dim rs
set rs = conn.execute("select id from NCMS_class where parent=" & id)
while not rs.eof
allchildclass = allchildclass & "," & rs("id")
allchildclass = allchildclass & allchildclass(rs("id"))
rs.movenext
wend
rs.close:set rs = nothing
end function
function getclassall(id,stype)
dim rs,tempstr
select case stype
case "1"
set rs = conn.execute("select ctemp from NCMS_class where id=" & id)
if not rs.eof then
tempstr = rs("ctemp")
end if
rs.close:set rs = nothing
getclassall = tempstr
case "2"
set rs = conn.execute("select ntemp from NCMS_class where id=" & id)
if not rs.eof then
tempstr = rs("ntemp")
end if
rs.close:set rs = nothing
getclassall = tempstr
case "3"
set rs = conn.execute("select fname from NCMS_class where id=" & id)
if not rs.eof then
tempstr = rs("fname")
end if
rs.close:set rs = nothing
getclassall = tempstr
case else
response.write("获取栏目属性失败!")
response.end()
end select
end function
function advshow(advcode)
if advcode = "" then
advshow = ""
exit function
else
dim advarr
advarr = split(advcode,"|||")
if ubound(advarr) = 0 then
advshow = "" & chr(10) & "<table style=""padding:0px;width:250px;height:250px"" cellspacing=""0"" cellpadding=""0"" align=""left"" border=""0"">" & chr(10)
advshow = advshow & "<tr>" & chr(10)
advshow = advshow & "<td>" & advcode & "</td>" & chr(10)
advshow = advshow & "</tr>" & chr(10)
advshow = advshow & "</table>" & chr(10)
else
dim n:randomize
n = int((ubound(advarr) + 1) * rnd)
advshow = "" & chr(10) & "<table style=""padding:0px;width:250px;height:250px"" cellspacing=""0"" cellpadding=""0"" align=""left"" border=""0"">" & chr(10)
advshow = advshow & "<tr>" & chr(10)
advshow = advshow & "<td>" & advarr(n) & "</td>" & chr(10)
advshow = advshow & "</tr>" & chr(10)
advshow = advshow & "</table>" & chr(10)
end if
end if
end function
function click(id)
click = "<script language=""javascript"" type=""text/javascript"" src=""" & site_root & "/tools/click.asp?id=" & id & """></script>"
end function
function fontselect()
fontselect = "" & chr(10) & "<div id=""fontselect"">" & chr(10)
fontselect = fontselect & "<ul>" & chr(10)
fontselect = fontselect & "<li id=""explain"">字体大小</li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(12)"">小</a></li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(14)"">中</a></li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(16)"">大</a></li>" & chr(10)
fontselect = fontselect & "</ul>" & chr(10)
fontselect = fontselect & "</div>" & chr(10)
end function
function toolbar(id)
toolbar = "" & chr(10) & "<div id=""toolbar"">" & chr(10)
toolbar = toolbar & "<ul>" & chr(10)
toolbar = toolbar & "<li id=""explain"">浏览工具</li>" & chr(10)
toolbar = toolbar & "<li><a href=""" & site_root & "/tools/comment.asp?newsid=" & id & "&newstitle=" & getnewstitle(id) & "#comment"" target=""_blank"" title=""新闻评论"">新闻评论</a><li>" & chr(10)
toolbar = toolbar & "<li><a href=""javascript:window.print()"" title=""打印本文"">打印本文</a><li>" & chr(10)
toolbar = toolbar & "<li><a href=""javascript:window.close()"" title=""关闭本页"">关闭本页</a><li>" & chr(10)
toolbar = toolbar & "<li><a href=""javascript:scroll(0,0)"" title=""返回页首"">返回页首</a><li>" & chr(10)
toolbar = toolbar & "</ul>" & chr(10)
toolbar = toolbar & "</div>" & chr(10)
end function
function copyurl()
copyurl = "" & chr(10) & "<div id=""copyurl"">" & chr(10)
copyurl = copyurl & "<script language=""javascript"" type=""text/javascript"">document.write('<input name=""url"" type=""text"" value=""' + window.location.href + '"" readonly=""true"" /><input name=""btn"" type=""button"" value=""复制本页地址与好友分享"" onclick=""copyurl();"" />');</script>" & chr(10)
copyurl = copyurl & "</div>" & chr(10)
end function
function search()
search = "" & chr(10) & "<div id=""search"">" & chr(10)
search = search & "<form name=""form"" action=""" & site_root & "/tools/search.asp"" method=""get"">" & chr(10)
search = search & "<input name=""kw"" type=""text"" value="""" />" & chr(10)
search = search & "<select name=""tn"">" & chr(10)
search = search & "<option value=""1"">标题</option>" & chr(10)
search = search & "<option value=""2"">作者</option>" & chr(10)
search = search & "<option value=""3"">内容</option>" & chr(10)
search = search & "</select>" & chr(10)
search = search & "<input name=""do"" type=""hidden"" value=""ok"" />" & chr(10)
search = search & "<input name=""search"" type=""submit"" value=""搜索"" />" & chr(10)
search = search & "</form>" & chr(10)
search = search & "</div>" & chr(10)
end function
function rannumkey(digits)
dim chararray(10)
chararray(0) = "0"
chararray(1) = "1"
chararray(2) = "2"
chararray(3) = "3"
chararray(4) = "4"
chararray(5) = "5"
chararray(6) = "6"
chararray(7) = "7"
chararray(8) = "8"
chararray(9) = "9"
randomize
do while len(output) < digits
dim num:num = cstr(chararray(int((10-0+1) * rnd + 0)))
dim output:output = output + num
loop
rannumkey = output
end function
function makefntype(datestr,types,classid)
select case types
case "1"
makefntype = year(datestr) & "/" & month(datestr) & "-" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年/月-日/随机数
case "2"
makefntype = year(datestr) & "/" & month(datestr) & "/" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年/月/日/随机数
case "3"
makefntype = year(datestr) & "-" & month(datestr) & "-" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年-月-日/随机数
case "4"
makefntype = year(datestr) & "-" & month(datestr) & "/" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年-月/日/随机数
case "5"
makefntype = year(datestr) & "/" & month(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年/月/随机数
case "6"
makefntype = year(datestr) & "-" & month(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年-月/随机数
case "7"
makefntype = year(datestr) & month(datestr) & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年月日/随机数
case "8"
makefntype = year(datestr) & "/" & getclassall(classid,3) & rannumkey(8) '年/随机数
case "9"
makefntype = year(datestr) & month(datestr) & day(datestr) & rannumkey(3) '年月日随机数
case "10"
makefntype = getclassall(classid,3) & rannumkey(16) '16位随机数
case "11"
makefntype = getclassall(classid,3) & md5(datestr & rannumkey(3),16) '16位md5加密字符
case "12"
makefntype = getclassall(classid,3) & year(datestr) & month(datestr) & day(datestr) & hour(datestr) & minute(datestr) & second(datestr) & rannumkey(3) '年月日时分秒随机数
case else
makefntype = getclassall(classid,3) & year(datestr) & month(datestr) & day(datestr) & hour(datestr) & minute(datestr) & second(datestr) & rannumkey(3) '年月日时分秒随机数
end select
end function
function dateformat(datestr,types)
dim datestring
if isdate(datestr) = false then
datestring = ""
end if
select case types
case "1"
datestring = year(datestr) & "-" & month(datestr) & "-" & day(datestr)
case "2"
datestring = year(datestr) & "." & month(datestr) & "." & day(datestr)
case "3"
datestring = month(datestr) & "-" & day(datestr) & "-" & year(datestr)
case "4"
datestring = month(datestr) & "." & day(datestr) & "." & year(datestr)
case "5"
datestring = year(datestr) & month(datestr) & day(datestr)
case "6"
datestring = hour(datestr) & minute(datestr) & second(datestr)
case "7"
datestring = year(datestr) & "年" & month(datestr) & "月" & day(datestr) & "日"
case else
datestring = datestr
end select
dateformat = datestring
end function
function formattagdate(mdate,temp)
if not isdate(mdate) or temp = "" then
formattagdate = temp
exit function
end if
dim myear:myear = year(mdate)
dim mmonth:mmonth = month(mdate)
dim mday:mday = day(mdate)
dim mhour:mhour = hour(mdate)
dim mmin:mmin = minute(mdate)
dim msec:msec = second(mdate)
temp = replace(temp,"{Y}",year(mdate))
temp = replace(temp,"{y}",right(year(mdate),2))
temp = replace(temp,"{M}",month(mdate))
temp = replace(temp,"{m}",right("00" & month(mdate),2))
temp = replace(temp,"{D}",day(mdate))
temp = replace(temp,"{d}",right("00" & day(mdate),2))
formattagdate = temp
end function
function strlength(str)
on error resume next
dim winnt_chinese
winnt_chinese = (len("中国") = 2)
if winnt_chinese then
dim l, t, c
dim i
l = len(str)
t = l
for i = 1 to l
c = asc(mid(str,i,1))
if c < 0 then c = c + 65536
if c > 255 then
t = t + 1
end if
next
strlength = t
else
strlength = len(str)
end if
if err.number <> 0 then err.clear
end function
function gottopic(byval str,byval strlen)
if str = "" or str = null then
gottopic = ""
exit function
end if
dim l,t,c,i,tstr
str = replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l = len(str)
t = 0
tstr = str
strlen = clng(strlen)
for i = 1 to l
c = abs(asc(mid(str,i,1)))
if c > 255 then
t = t + 2
else
t = t + 1
end if
if t >= strlen then
tstr = left(str,i)
exit for
end if
next
if tstr <> str then
tstr = tstr & "..."
end if
gottopic = replace(replace(replace(replace(tstr," "," "),chr(34),"""),">",">"),"<","<")
end function
function insertchr(num)
dim str1:str1 = "├"
dim str2:str2 = ""
dim iii
for iii = 2 to num
str2 = str2 & "│ "
next
insertchr = str2&str1
end function
class classlist
private class_id
private class_table
private class_parentid
private class_name
public property let id(str)
class_id = str
end property
public property let table(str)
class_table = str
end property
public property let parentid(str)
class_parentid = str
end property
public property let name(str)
class_name = str
end property
dim list()
dim i,n
private sub class_initialize()
i = 0:n = 0
end sub
public function classarry(thisid,id)
dim rsclass,classsql
if id > 0 then
classsql = "select * from " & class_table & " where " & class_parentid & "=" & thisid
else
classsql = "select * from " & class_table & " where " & class_id & "=" & thisid
end if
set rsclass = conn.execute(classsql)
n = n + 1
do while not rsclass.eof
list(0,i) = rsclass(class_id)
list(1,i) = rsclass(class_name)
list(2,i) = n
i = i + 1
thisid = classarry(rsclass(class_id),1)
rsclass.movenext
loop
n = n - 1
rsclass.close
end function
public function arrylist()
dim rsclass
set rsclass = conn.execute("select count(" & class_id & ") from " & class_table)
dim lenght
lenght = rsclass(0)
rsclass.close
redim list(2,lenght)
dim rspclass
set rspclass = conn.execute("select " & class_id & " from " & class_table & " where " & class_parentid & "=0")
do while not rspclass.eof
call classarry(rspclass(class_id),0)
rspclass.movenext
loop
rspclass.close
arrylist = list
end function
end class
class imginfo
dim aso
private sub class_initialize
set aso = createobject("adodb.stream")
aso.mode = 3
aso.type = 1
aso.open
end sub
private sub class_terminate
err.clear
set aso = nothing
end sub
private function bin2str(bin)
dim i,str,clow
for i = 1 to lenb(bin)
clow = midb(bin,i,1)
if ascb(clow) < 128 then
str = str & chr(ascb(clow))
else
i = i + 1
if i <= lenb(bin) then
str = str & chr(ascw(midb(bin,i,1)&clow))
end if
end if
next
bin2str = str
end function
private function num2str(num,base,lens)
dim ret
ret = ""
while(num>=base)
ret = (num mod base) & ret
num = (num - num mod base)/base
wend
num2str = right(string(lens,"0") & num & ret,lens)
end function
private function str2num(str,base)
dim ret
ret = 0
for i = 1 to len(str)
ret = ret *base + cint(mid(str,i,1))
next
str2num = ret
end function
private function binval(bin)
dim ret
ret = 0
dim i
for i = lenb(bin) to 1 step -1
ret = ret*256 + ascb(midb(bin,i,1))
next
binval = ret
end function
private function binval2(bin)
dim ret
ret = 0
Dim i
for i = 1 to lenb(bin)
ret = ret*256 + ascb(midb(bin,i,1))
next
binval2 = ret
end function
private function getimagesize(filespec)
dim ret(3)
aso.loadfromfile(filespec)
dim bflag
bflag = aso.read(3)
select case hex(binval(bflag))
case "4E5089":
aso.read(15)
ret(0) = "PNG"
ret(1) = binval2(aso.read(2))
aso.read(2)
ret(2) = binval2(aso.read(2))
case "464947":
aso.read(3)
ret(0) = "GIF"
ret(1) = binval(aso.read(2))
ret(2) = binval(aso.read(2))
case "535746":
aso.read(5)
bindata = aso.read(1)
sconv = num2str(ascb(bindata),2,8)
nbits = str2num(left(sconv,5),2)
sconv = mid(sconv,6)
while(len(sconv)<nbits*4)
bindata = aso.read(1)
sconv = sconv & num2str(ascb(bindata),2,8)
wend
ret(0) = "SWF"
ret(1) = int(abs(str2num(mid(sconv,1*nbits+1,nbits),2)-str2num(mid(sconv,0*nbits+1,nbits),2))/20)
ret(2) = int(abs(str2num(mid(sconv,3*nbits+1,nbits),2)-str2num(mid(sconv,2*nbits+1,nbits),2))/20)
case "FFD8FF":
do
dim p1
do:p1 = binval(aso.read(1)):loop while p1 = 255 and not aso.eos
if p1 > 191 and p1 < 196 then exit do else aso.read(binval2(aso.read(2))-2)
do:p1 = binval(aso.read(1)):loop while p1 < 255 and not aso.eos
loop while true
aso.read(3)
ret(0) = "JPG"
ret(2) = binval2(aso.read(2))
ret(1) = binval2(aso.read(2))
case else:
if left(bin2str(bflag),2) = "BM" then
aso.read(15)
ret(0) = "BMP"
ret(1) = binval(aso.read(4))
ret(2) = binval(aso.read(4))
else
ret(0) = ""
end if
end select
ret(3)="width=""" & ret(1) &""" height=""" & ret(2) &""""
getimagesize = ret
end function
public function imgW(pic_path)
dim imgfso
set imgfso = server.createobject("scripting.filesystemobject")
if (imgfso.fileexists(pic_path)) then
dim imgfs,ext
set imgfs = imgfso.getfile(pic_path)
ext = imgfso.getextensionname(pic_path)
select case ext
case "gif","bmp","jpg","png":
dim arr
arr = getimagesize(imgfs.path)
imgW = arr(1)
end select
set imgfs = nothing
else
imgW = 0
end if
set imgfso = nothing
end function
public function imgH(pic_path)
dim imgfso
set imgfso = server.createobject("scripting.filesystemobject")
if (imgfso.fileexists(pic_path)) then
dim imgfs,ext
set imgfs = imgfso.getfile(pic_path)
ext = imgfso.getextensionname(pic_path)
select case ext
case "gif","bmp","jpg","png":
dim arr
arr = getimagesize(imgfs.path)
imgH = arr(2)
end select
set imgfs = nothing
else
imgH = 0
end if
set imgfso = nothing
end function
end class
function gfv(str)
gfv = request.form(str)
end function
function guv(str)
guv = request.querystring(str)
end function
function alertbox(str,kindnum)
select case kindnum
case "1"
response.write("<script>alert(""" & str & """);</script>")
response.end()
case "2"
response.write("<script>alert(""" & str & """);window.history.back();</script>")
response.end()
case "3"
response.write("<script>alert(""" & str & """);window.close();</script>")
response.end()
end select
end function
sub WRITE_LINE(str)
response.write ltrim(str)
end sub
sub LOADING_BUFFER_INI
response.expires = 0
response.expiresabsolute = now() - 1
response.addheader "pragma","no-cache"
response.addheader "cache-control","private"
response.cachecontrol = "no-cache"
end sub
sub LOADING_ADMIN_HEAD
WRITE_LINE "<html><head><title></title>"
WRITE_LINE "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">"
WRITE_LINE "<meta http-equiv=""Content-Language"" content=""gb2312"">"
WRITE_LINE "<link href=""../images/ncms/css.css"" rel=""stylesheet"" type=""text/css""></head>"
WRITE_LINE "<body leftmargin=""1"" topmargin=""10"" scroll=""auto"">"
end sub
sub LOADING_ADMIN_FOOT
if isobject("conn") then
conn.close:set conn = nothing
elseif isobject("commentconn") then
commentconn.close:set commentconn = nothing
elseif isobject("collectconn") then
collectconn.close:set collectconn = nothing
end if
WRITE_LINE "<table align=""center"" width=""100%"" cellpadding=""2"" cellspacing=""1"" border=""0"">"
WRITE_LINE "<tr>"
WRITE_LINE "<td align=""middle"" valign=""middle"">"
WRITE_LINE "<table bgcolor=""#c0c0c0"" align=""center"" width=""98%"" cellpadding=""2"" cellspacing=""1"">"
WRITE_LINE "<tr>"
WRITE_LINE "<td bgcolor=""#f0f0f0"" height=""50""><div align=""center""><font face=""verdana,arial,helvetica,sans-serif"" size=""1""><b>©2006 - 2008 CopyRight NCMS All Rights Reserved.Version:" & Version & " <a href=""http://www.50z.cn/"" target=""_blank"">BBS</a></b></font></div></td>"
WRITE_LINE "</tr>"
WRITE_LINE "</table>"
WRITE_LINE "</td>"
WRITE_LINE "</tr>"
WRITE_LINE "</table>"
WRITE_LINE "</body></html>"
end sub
'===============================================================================================
'楚河|汉界 来个小广告:如果您发现本程序BUG或不足之处或有好的改进方法,请联系我:QQ574634!万分感谢!
'===============================================================================================
Function IsValidEmail(Str)
IsValidEmail = False
Dim RegEx,Match
Set RegEx = New RegExp
RegEx.Pattern = "^\w+((-\w+)|(\.\w+))*\@[A-Za-z0-9]+((\.|-)[A-Za-z0-9]+)*\.[A-Za-z0-9]+$"
RegEx.IgnoreCase = True
Set Match = RegEx.Execute(Str)
If Match.Count Then IsValidEmail = True
End Function
Function ChkNum(Byval Num)
Dim tNum:tNum = ""
If Num = "" Or Not IsNumeric(Num) Then
Response.Write("<script>alert(""参数类型错误!"");history.back();</script>")
Response.End()
ElseIf len(Num) > 8 Then
Response.Write("<script>alert(""参数超出范围!"");history.back();</script>")
Response.End()
Else
tNum = clng(left(Num,8))
End If
ChkNum = tNum
End Function
Function ChkStr(ByVal Str)
Dim TempStr
TempStr = Replace(Replace(Str,"'",""),Chr(39),"")
Dim RegEx
Set RegEx = New RegExp
RegEx.IGnoreCase = True
RegEx.Pattern = "<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|url|eval|\t"
If RegEx.Test(LCase(TempStr)) Then
TempStr = ""
End If
Set RegEx = Nothing
ChkStr = TempStr
End Function
Function FuckJP(ByVal Str)
If IsNull(Str) Or IsEmpty(Str) Then Exit Function
Dim F,I
F = Array("ゴ","ガ","ギ","グ","ゲ","ザ","ジ","ズ","ヅ","デ","ド","ポ","ベ","プ","ビ","パ","ヴ","ボ","ペ","ブ","ピ","バ","ヂ","ダ","ゾ","ゼ")
FuckJP = Str
For I = 0 To 25
FuckJP = Replace(FuckJP,F(I),"")
Next
End Function
Function ChkInput(Str)
Dim RegEx
Set RegEx = New RegExp
RegEx.IgnoreCase = True
RegEx.Pattern = "<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|url|eval|\t"
If RegEx.Test(LCase(Str)) Then
Response.Write("处理 URL 时服务器出错，请与系统管理员联系。")
Response.End()
End If
Set RegEx = Nothing
ChkInput = Str
End Function
Function ChkPost()
Dim From_Url:From_Url = CStr(Request.ServerVariables("HTTP_REFERER"))
Dim Serv_Url:Serv_Url = CStr(Request.ServerVariables("SERVER_NAME"))
If Mid(From_Url,8,Len(Serv_Url)) <> Serv_Url Then
Response.Write("处理 URL 时服务器出错，请与系统管理员联系。")
Response.End()
End If
End Function
Function GetIP()
Dim StrIP_List,StrIP,IP_Ary
StrIP_List = Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","")
If InStr(StrIP_List,",") <> 0 Then
IP_Ary = Split(StrIP_List,",")
StrIP = IP_Ary(0)
Else
StrIP = StrIP_List
End If
If StrIP = Empty Then StrIP = Replace(Request.ServerVariables("REMOTE_ADDR"),"'","")
GetIP = StrIP
End Function
Function Highlight(byVal strContent,byRef arrayWords)
Dim intCounter,strTemp,intPos,intTagLength,intKeyWordLength,bUpDate
If Len(arrayWords) < 1 Then Highlight = strContent:Exit Function
For intPos = 1 To Len(strContent)
bUpDate = False
If Mid(strContent,intPos,1) = "<" Then
On Error Resume Next
intTagLength = (InStr(intPos,strContent,">",1) - intPos)
If Err.Number <> 0 Then
Highlight = strContent
Err.Clear
End If
strTemp = strTemp & Mid(strContent,intPos,intTagLength)
intPos = intPos + intTagLength
End If
If arrayWords <> "" Then
intKeyWordLength = Len(arrayWords)
If LCase(Mid(strContent,intPos,intKeyWordLength)) = LCase(arrayWords) Then
strTemp = strTemp & "<strong style=""color:#ff0000;background:#fff000;"">" & Mid(strContent,intPos,intKeyWordLength) & "</strong>"
intPos = intPos + intKeyWordLength - 1
bUpDate = True
End If
End If
If bUpDate = False Then
strTemp = strTemp & Mid(strContent,intPos,1)
End If
Next
Highlight = strTemp
End Function
Function SendToNcms(Str1,Str2,Str3,Str4)
On Error Resume Next
WRITE_LINE "<script>setTimeout(""document.form.submit()"",0);</script>"
WRITE_LINE "<form name=""form"" action=""http://ncms.cn/users/receive.asp"" method=""post"">"
WRITE_LINE "<input name=""k1"" type=""hidden"" value=""" & Str1 & """>"
WRITE_LINE "<input name=""k2"" type=""hidden"" value=""" & Str2 & """>"
WRITE_LINE "<input name=""k3"" type=""hidden"" value=""" & Str3 & """>"
WRITE_LINE "<input name=""k4"" type=""hidden"" value=""" & Str4 & """>"
WRITE_LINE "<input name=""kx"" type=""hidden"" value=""203674122566320014"">"
WRITE_LINE "</form>"
End Function
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 GetVer(ClassStr)
On Error Resume Next
GetVer = ""
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(ClassStr)
If 0 = Err Then GetVer = xTestObj.Version
Set xTestObj = Nothing
Err = 0
End Function
Function ReplaceRemoteUrl(sHTML,sSavePath,sExt)
Dim s_Content:s_Content = sHTML
If IsObjInstalled("Microsoft.XMLHTTP") = False Then
ReplaceRemoteUrl = s_Content
Exit Function
End If
If sSavePath = "" Then sSavePath = "" & site_root & "/" & site_upload & "/" & site_bimg & "/"
If sExt = "" Then sExt = "jpg|gif|png|bmp|swf"
Dim RegEx,RemoteFile,RemoteFileurl,SaveFileName,OutPutPath,SaveFileType,RanNum,NewFileName
Set RegEx = New RegExp
RegEx.IgnoreCase = True
RegEx.Global = True
RegEx.Pattern = "(http://(.+?)\.(" & sExt & "))"
Set RemoteFile = RegEx.Execute(s_Content)
For Each RemoteFileurl In RemoteFile
SaveFileType = Mid(RemoteFileurl,InstrRev(RemoteFileurl,".") + 1)
Randomize
RanNum = Int(900 * Rnd) + 100
NewFileName = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now) & RanNum & "." & SaveFileType
SaveFileName = sSavePath & NewFileName
OutPutPath = "" & site_root & "/tools/loadimg.asp?FileName=" & NewFileName & ""
Call SaveRemoteFile(SaveFileName,RemoteFileurl)
s_Content = Replace(s_Content,RemoteFileurl,OutPutPath)
Next
ReplaceRemoteUrl = NewFileName & "|" & s_Content
End Function
Sub SaveRemoteFile(s_LocalFileName,s_RemoteFileUrl)
Dim Ads,Retrieval,GetRemoteData
On Error Resume Next
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get",s_RemoteFileUrl,False,"",""
.Send
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
Set Ads = Server.CreateObject("ADODB.Stream")
Ads.Type = 1
Ads.Open
Ads.Write GetRemoteData
Ads.SaveToFile Server.Mappath(s_LocalFileName),2
Ads.Cancel()
Ads.Close()
Set Ads = Nothing
End Sub
Class Cls_vbsPage
Private oConn
Private iPagesize
Private sPageName
Private sDbType
Private iRecType
Private sJsUrl
Private sField
Private sTable
Private sCondition
Private sOrderBy
Private sPkey
Private iRecCount
Private Sub Class_Initialize
iPageSize=10
sPageName="Page"
sDbType="AC"
iRecType=0
sJsUrl=""
sField=" * "
End Sub
Public Property Set Conn(ByRef Value)
Set oConn=Value
End Property
Public Property Let PageSize(ByVal intPageSize)
iPageSize=CheckNum(intPageSize,0,0,iPageSize,0)
End Property
Public Property Let PageName(ByVal strPageName)
sPageName=IIf(Len(strPageName)<1,sPageName,strPageName)
End Property
Public Property Let DbType(ByVal strDbType)
sDbType=UCase(IIf(Len(strDbType)<1,sDbType,strDbType))
End Property
Public Property Let RecType(ByVal intRecType)
iRecType=CheckNum(intRecType,0,0,iRecType,0)
End Property
Public Property Let JsUrl(ByVal strJsUrl)
sJsUrl=strJsUrl
End Property
Public Property Let Pkey(ByVal strPkey)
sPkey=strPkey
End Property
Public Property Let Field(ByVal strField)
sField=IIf(Len(strField)<1,sField,strField)
End Property
Public Property Let Table(ByVal strTable)
sTable=strTable
End Property
Public Property Let Condition(ByVal strCondition)
Dim s
s=strCondition
sCondition=IIf(Len(s)>2," WHERE "&s,"")
End Property
Public Property Let OrderBy(ByVal strOrderBy)
Dim s
s=strOrderBy
sOrderBy=IIf(Len(s)>4," ORDER BY "&s,"")
End Property
Public Property Get RecCount()
If iRecType>0 Then
i=iRecType
Elseif iRecType=0 Then
i=CheckNum(Request.Cookies("ShowoPage")(sPageName),1,0,0,0)
Dim s
s=Trim(Request.Cookies("ShowoPage")("sCond"))
IF i=0 OR sCondition<>s Then
i=oConn.Execute("SELECT COUNT("&sPkey&") FROM "&sTable&" "&sCondition,0,1)(0)
Response.Cookies("ShowoPage")(sPageName)=i
Response.Cookies("ShowoPage")("sCond")=sCondition
End If
Else
i=oConn.Execute("SELECT COUNT("&sPkey&") FROM "&sTable&" "&sCondition,0,1)(0)
End If
iRecCount=i
RecCount=i
End Property
Public Property Get ResultSet()
Dim s
s=Null
i=iRecCount
If i>0 Then
Dim iPageCount,iPageCurr
iPageCount=Abs(Int(-Abs(i/iPageSize)))
iPageCurr=CheckNum(Request.QueryString(sPageName),1,1,1,iPageCount)
Select Case sDbType
Case "MSSQL"
Set Rs=server.CreateObject("Adodb.RecordSet")
Set Cm=Server.CreateObject("Adodb.Command")
Cm.CommandType=4
Cm.ActiveConnection=oConn
Cm.CommandText="sp_Util_Page"
Cm.parameters(1)=i
Cm.parameters(2)=iPageCurr
Cm.parameters(3)=iPageSize
Cm.parameters(4)=sPkey
Cm.parameters(5)=sField
Cm.parameters(6)=sTable
Cm.parameters(7)=Replace(sCondition," WHERE ","")
Cm.parameters(8)=Replace(sOrderBy," ORDER BY ","")
Rs.CursorLocation=3
Rs.LockType=1
Rs.Open Cm
Case "MYSQL"
ResultSet_Sql="SELECT "&sField&" FROM "&sTable&" "&sCondition&" "&sOrderBy&" LIMIT "&(iPageCurr-1)*iPageSize&","&iPageSize
Set Rs=oConn.Execute(ResultSet_Sql)
Case Else
Dim Rs,ResultSet_Sql
Set Rs = Server.CreateObject ("Adodb.RecordSet")
ResultSet_Sql="SELECT "&sField&" FROM "&sTable&" "&sCondition&" "&sOrderBy
Rs.Open ResultSet_Sql,oConn,1,1,&H0001
Rs.AbsolutePosition=(iPageCurr-1)*iPageSize+1
End Select
s=Rs.GetRows(iPageSize)
Rs.close
Set Rs=Nothing
End If
ResultSet=s
End Property
Private Sub Class_Terminate()
If IsObject(oConn) Then oConn.Close:Set oConn=Nothing
End Sub
Private Function CheckNum(ByVal strStr,ByVal blnMin,ByVal blnMax,ByVal intMin,ByVal intMax)
Dim i,s,iMi,iMa
s=Left(Trim(""&strStr),32):iMi=intMin:iMa=intMax
If IsNumeric(s) Then
i=CDbl(s)
i=IIf(blnMin=1 And i<iMi,iMi,i)
i=IIf(blnMax=1 And i>iMa,iMa,i)
Else
i=iMi
End If
CheckNum=i
End Function
Private Function IIf(ByVal blnBool,ByVal strStr1,ByVal strStr2)
Dim s
If blnBool Then
s=strStr1
Else
s=strStr2
End If
IIf=s
End Function
Public Sub ShowPage()
%>
<script language="javascript" type="text/javascript" src="<%=sJsUrl%>/page.js"></script>
<script language="javascript" type="text/javascript">
var s = new Cls_jsPage(<%=iRecCount%>,<%=iPageSize%>,3,"s");
s.setPageSE("<%=sPageName%>=","");
s.setPageInput("<%=sPageName%>");
s.setUrl("");
s.setPageFrist("首页","<<");
s.setPagePrev("上页","<");
s.setPageNext("下页",">");
s.setPageLast("尾页",">>");
s.setPageText("[{$PageNum}]","第{$PageNum}页");
s.setPageTextF(" {$PageTextF} "," {$PageTextF} ");
s.setPageSelect("{$PageNum}","第{$PageNum}页");
s.setPageCss("","","");
s.setHtml("共{$RecCount}记录 页次{$Page}/{$PageCount} 每页{$PageSize}条 {$PageFrist} {$PagePrev} {$PageText} {$PageNext} {$PageLast} {$PageInput} {$PageSelect}");
s.Write();
</script>
<%
End Sub
End Class
Function GetHttpPage(HttpUrl)
On Error Resume Next
If IsNull(HttpUrl) = True Or Len(HttpUrl) < 18 Or HttpUrl = "$False$" Then
GetHttpPage = "$False$"
Exit Function
End If
Dim Http
Set Http = Server.CreateObject("Microsoft.XMLHTTP")
Http.Open "GET",HttpUrl,False
Http.Send()
If Http.Readystate <> 4 Then
Set Http = Nothing
GetHttpPage = "$False$"
Exit function
End If
GetHTTPPage = BytesToBstr(Http.ResponseBody,"GB2312")
Set Http = Nothing
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
End Function
Function BytesToBstr(Body,Cset)
Dim ObjStream
Set ObjStream = Server.CreateObject("ADODB.Stream")
ObjStream.Type = 1
ObjStream.Mode = 3
ObjStream.Open
ObjStream.Write Body
ObjStream.Position = 0
ObjStream.Type = 2
ObjStream.Charset = Cset
BytesToBstr = ObjStream.ReadText
ObjStream.Close
Set ObjStream = Nothing
End Function
Function GetAllLinkTags(ContStr)
Dim RegEx,Match,Matches,TempStr
Set RegEx = New RegExp
RegEx.Pattern = "<a .*?>.*?</a>"
RegEx.IGnoreCase = True
RegEx.Global = True
Set Matches = RegEx.Execute(ContStr)
For Each Match In Matches
TempStr = TempStr & Match.Value & "|||"
Next
Set Matches = Nothing
Set RegEx = Nothing
GetAllLinkTags = TempStr
End Function
Function GetOtherContent(Str,StartStr,LastStr)
On Error Resume Next
Dim RegEx,SearchStr,Matches,Matche
Str = Replace(Replace(Str,Chr(13),""),Chr(10),"")
StartStr = Replace(Replace(StartStr,Chr(13),""),Chr(10),"")
LastStr = Replace(Replace(LastStr,Chr(13),""),Chr(10),"")
SearchStr = StartStr & ".*" & LastStr
Set RegEx = New RegExp
RegEx.IgnoreCase = True
RegEx.Global = True
RegEx.Pattern = SearchStr
Set Matches = RegEx.Execute(Str)
For Each Matche In Matches
If Matche <> "" Then
GetOtherContent = Matche
RegEx.Pattern = StartStr
GetOtherContent = RegEx.Replace(GetOtherContent,"")
RegEx.Pattern = LastStr & ".*|\n"
GetOtherContent = RegEx.Replace(GetOtherContent,"")
Else
GetOtherContent = ""
End If
If Err.Number <> 0 Then
Err.Clear
GetOtherContent = ""
End If
Exit For
Next
End Function
Function FormatUrl(NewsLinkStr,ObjUrl)
Dim URLSearchLoc
If Left(LCase(NewsLinkStr),7) <> "http://" Then
Dim CheckURLStr,TempCollectObjUrl,CheckObjUrl
NewsLinkStr = Replace(Replace(Replace(NewsLinkStr,"'",""),"""","")," ","")
TempCollectObjUrl = Left(ObjUrl,InStrRev(ObjUrl,"/"))
CheckObjUrl = NewsLinkStr
CheckURLStr = Left(NewsLinkStr,3)
If Left(NewsLinkStr,1) = "/" Then
URLSearchLoc = InStr(ObjUrl,"//") + 2
FormatUrl = Left(ObjUrl,InStr(URLSearchLoc,ObjUrl,"/") - 1)
FormatUrl = FormatUrl & NewsLinkStr
ElseIf CheckURLStr = "../" Then
Do While Not CheckURLStr <> "../"
CheckObjUrl = Mid(CheckObjUrl,4)
If Right(TempCollectObjUrl,1) = "/" Then TempCollectObjUrl = Left(TempCollectObjUrl,Len(TempCollectObjUrl) - 1)
TempCollectObjUrl = Left(TempCollectObjUrl,InStrRev(TempCollectObjUrl,"/"))
CheckURLStr = Left(CheckObjUrl,3)
Loop
FormatUrl = TempCollectObjUrl & CheckObjUrl
Else
FormatUrl = TempCollectObjUrl & NewsLinkStr
End If
Else
FormatUrl = NewsLinkStr
End If
End Function
Function ReplaceContentStr(ContentStr)
Dim TempContentStr
TempContentStr = ContentStr
If RuleDataBox(14,0) = 1 Then
TempContentStr = LoseHtml(TempContentStr)
Else
TempContentStr = LoseNoteTag(TempContentStr)
If RuleDataBox(15,0) = 1 Then TempContentStr = LoseStyleTag(TempContentStr)
If RuleDataBox(16,0) = 1 Then TempContentStr = LoseDivTag(TempContentStr)
If RuleDataBox(17,0) = 1 Then TempContentStr = LoseATag(TempContentStr)
If RuleDataBox(18,0) = 1 Then TempContentStr = LoseFontTag(TempContentStr)
If RuleDataBox(19,0) = 1 Then TempContentStr = LoseSpanTag(TempContentStr)
If RuleDataBox(20,0) = 1 Then TempContentStr = LoseObjectTag(TempContentStr)
If RuleDataBox(21,0) = 1 Then TempContentStr = LoseIFrameTag(TempContentStr)
If RuleDataBox(22,0) = 1 Then TempContentStr = LoseScriptTag(TempContentStr)
If RuleDataBox(23,0) = 1 Then TempContentStr = LoseClassTag(TempContentStr)
TempContentStr = LoseTableTag(TempContentStr)
TempContentStr = LoseTDTag(TempContentStr)
TempContentStr = LoseTRTag(TempContentStr)
End If
ReplaceContentStr = TempContentStr
End Function
Function CNReplaceContentStr(ContentStr)
Dim TempContentStr
TempContentStr = ContentStr
If CNRuleDataBox(14,0) = 1 Then
TempContentStr = LoseHtml(TempContentStr)
Else
TempContentStr = LoseNoteTag(TempContentStr)
If CNRuleDataBox(15,0) = 1 Then TempContentStr = LoseStyleTag(TempContentStr)
If CNRuleDataBox(16,0) = 1 Then TempContentStr = LoseDivTag(TempContentStr)
If CNRuleDataBox(17,0) = 1 Then TempContentStr = LoseATag(TempContentStr)
If CNRuleDataBox(18,0) = 1 Then TempContentStr = LoseFontTag(TempContentStr)
If CNRuleDataBox(19,0) = 1 Then TempContentStr = LoseSpanTag(TempContentStr)
If CNRuleDataBox(20,0) = 1 Then TempContentStr = LoseObjectTag(TempContentStr)
If CNRuleDataBox(21,0) = 1 Then TempContentStr = LoseIFrameTag(TempContentStr)
If CNRuleDataBox(22,0) = 1 Then TempContentStr = LoseScriptTag(TempContentStr)
If CNRuleDataBox(23,0) = 1 Then TempContentStr = LoseClassTag(TempContentStr)
TempContentStr = LoseTableTag(TempContentStr)
TempContentStr = LoseTDTag(TempContentStr)
TempContentStr = LoseTRTag(TempContentStr)
End If
CNReplaceContentStr = TempContentStr
End Function
Function LoseHtml(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<\/*[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
Set RegEx = Nothing
LoseHtml = ClsTempLoseStr
End function
Function LoseClassTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "(class=){1,}(""|\'){0,1}\S+(""|\'|>|\s){0,1}"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseClassTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseScriptTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "(<script){1,}[^<>]*>[^\0]*(<\/script>){1,}"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseScriptTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseIFrameTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "(<iframe){1,}[^<>]*>[^\0]*(<\/iframe>){1,}"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseIFrameTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseObjectTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "(<object){1,}[^<>]*>[^\0]*(<\/object>){1,}"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseObjectTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseSpanTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}span[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseSpanTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseFontTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}font[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseFontTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseATag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}a[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseATag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseDivTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}div[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseDivTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseStyleTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "(<style){1,}[^<>]*>[^\0]*(<\/style>){1,}"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseStyleTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseNoteTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<!--\/*[^<>]*-->"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseNoteTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseTableTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}table[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseTableTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseTDTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}td[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseTDTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
Function LoseTRTag(ContentStr)
Dim ClsTempLoseStr,RegEx
ClsTempLoseStr = Cstr(ContentStr)
Set RegEx = New RegExp
RegEx.Pattern = "<(\/){0,1}tr[^<>]*>"
RegEx.IgnoreCase = True
RegEx.Global = True
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr,"")
LoseTRTag = ClsTempLoseStr
Set RegEx = Nothing
End Function
%>
加载全部内容