<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%
'******************************************************************************************
' Software name: Max(马克斯) Content Management System
' Version:2.8
' Web: http://maxcms.bokecc.com
' Author: 石头(maxcms2008@qq.com),yuet,长明,酒瓶
' Copyright (C) 2005-2009 北京梦之窗数码科技有限公司 版权所有
' 法律申明：MaxCMS程序所有代码100%原创、未引入任何网上代码,对一切抄袭行为、坚决严肃追究法律责任
'******************************************************************************************
Option Explicit
dim starttime,endtime
setStartTime
const CONN_OBJ_NAME="ADODB.CONNECTION"
const RECORDSET_OBJ_NAME="ADODB.RECORDSET"
dim FSO_OBJ_NAME
FSO_OBJ_NAME="SCRI"&"PTING.FILES"&"YSTEMOBJECT"
dim STREAM_OBJ_NAME
STREAM_OBJ_NAME="ADOD"&"B.ST"&"REAM"
dim DICTIONARY_OBJ_NAME
DICTIONARY_OBJ_NAME="SCRIPTING.DICTIONARY"
dim JPEG_OBJ_NAME
JPEG_OBJ_NAME="Persits.jpeg"
dim TABLE_PRE
TABLE_PRE="m_"
Class MainClass
private className
Private Sub Class_Initialize
className=""
End Sub
Public Function createObject(byval classStr)
className=classStr
classname=replace(classname,".","_")
Execute("set createObject=new "&classname)
End Function
Private Sub Class_Terminate()
End Sub
End Class
Class MainClass_DB
public dbConn,dbRs,isConnect,fetchCount
private connStr,vqueryCount,vdbType
private errid,errdes
Private Sub Class_Initialize
isConnect=false
vqueryCount=0
fetchCount=0
End Sub
Public Property Get queryCount
queryCount=vqueryCount
End Property
Public Property Let dbType(byval pType)
if pType="sql" then vdbType=pType else vdbType="acc"
End Property
Private Sub getConnStr()
if vdbType="sql" then
connStr="Provider=Sqloledb;Data Source="&databaseServer&";Initial Catalog="&databaseName&";User ID="&databaseUser&";Password="&databasePwd&";"
elseif vdbType="acc" then
connStr="Provider=Microsoft.Jet.OLEdb.4.0;Data Source="&server.mappath(accessFilePath)
end if
End Sub
Public Sub connect()
getConnStr
if isObject(dbConn)=false or isConnect=false then
On Error Resume Next
set dbConn=server.CreateObject(CONN_OBJ_NAME)
dbConn.open connStr
isConnect=true
if Err then errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false:echoErr err_dbconect,errid,errdes
end if
End Sub
Function db(byval sqlStr,byval sqlType)
if not isConnect=true then connect
On Error Resume Next
sqlStr=replace(sqlStr,"{pre}",TABLE_PRE)
'echo sqlStr&" "
select case sqlType
case "execute"
set db=dbConn.execute(sqlStr)
case "records1"
set db=server.CreateObject(RECORDSET_OBJ_NAME)
db.open sqlStr,dbConn,1,1
case "records3"
set db=server.CreateObject(RECORDSET_OBJ_NAME)
db.open sqlStr,dbConn,3,3
case "array"
set dbRs=server.CreateObject(RECORDSET_OBJ_NAME)
dbRs.open sqlStr,dbConn,1,1
if not dbRs.eof then
if fetchCount=0 then db=dbRs.getRows() else db=dbRs.getRows(fetchCount)
end if
dbRs.close:set dbRs=nothing
end select
vqueryCount=vqueryCount+1
if Err then
errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false
echoErr err_rsopen,errid,errdes
end if
End Function
Public Sub Class_Terminate()
if isObject(dbRs) then set dbRs=nothing
if isConnect then dbConn.close:set dbConn=nothing:isConnect=false
End Sub
End Class
Class MainClass_Cache
Public continueTime,vcacheFlag
Private v_cacheName,cacheData,cacheNum
Private Sub Class_Initialize()
continueTime=clng(cacheTime)
vcacheFlag=cacheFlag
cacheNum=200
End Sub
Public Function setCache(ByVal p_cacheName,ByVal p_cacheValue)
if getCacheNum > cacheNum then clearOtherCache
on error resume next
v_cacheName=LCase(p_cacheName)
If v_cacheName<>"" Then
cacheData=Application(vcacheFlag&v_cacheName)
If IsArray(cacheData) Then
if isObject(p_cacheValue) then set cacheData(0)=p_cacheValue else cacheData(0)=p_cacheValue
cacheData(1)=Now()
Else
ReDim cacheData(1)
if isObject(p_cacheValue) then set cacheData(0)=p_cacheValue else cacheData(0)=p_cacheValue
cacheData(1)=Now()
End If
if err then clearAll : err.clear
Application.Lock
Application(vcacheFlag&v_cacheName)=cacheData
Application.unLock
Else
die err_cachename
End If
End Function
Public Function getCache(ByVal p_cacheName)
on error resume next
v_cacheName=LCase(p_cacheName)
If v_cacheName<>"" Then
cacheData=Application(vcacheFlag&v_cacheName)
If IsArray(cacheData) Then
if isObject(cacheData(0)) then set getCache=cacheData(0) else getCache=cacheData(0)
if err then clearAll : err.clear
Else
die err_cachevalue
End If
Else
die err_cachename
End If
End Function
Public Function chkCache(ByVal p_cacheName)
v_cacheName=LCase(p_cacheName)
chkCache=false
on error resume next
cacheData=Application(vcacheFlag&v_cacheName)
if err then clearAll : err.clear : Exit Function
If Not IsArray(cacheData) Then Exit Function
If Not IsDate(cacheData(1)) Then Exit Function
If DateDiff("s",CDate(cacheData(1)),Now()) < 60*continueTime Then
chkCache=true
End If
End Function
Public Sub clearCache(ByVal p_cacheName)
v_cacheName=LCase(p_cacheName)
Application.Lock
Application(vcacheFlag&v_cacheName)=Empty
Application.unLock
End Sub
Public Function havedTime(Byval p_cacheName)
v_cacheName=LCase(p_cacheName)
If v_cacheName<>"" Then
cacheData=Application(vcacheFlag&v_cacheName)
If IsArray(cacheData) Then
havedTime=cacheData(1)
Else
die err_cachevalue
End If
Else
die err_cachename
End If
End Function
Public Sub clearAll()
Application.Lock()
Application.Contents.RemoveAll()
Application.UnLock()
end sub
Public Sub showAllCache()
dim acon
echo "缓存对象列表：共"&getCacheNum()&"个: "
for each acon in Application.Contents
echo acon&" "
next
End Sub
Public Function getCacheNum()
getCacheNum=application.Contents.Count
End Function
Public Sub clearOtherCache()
dim acon,i,otherNum : otherNum=getCacheNum - cacheNum : i=0
for each acon in Application.Contents
Application.Lock()
application.contents.remove(acon)
Application.UnLock()
i=i + 1
if i=otherNum then exit for
next
End Sub
End Class
Class MainClass_Template
Public content,allPages,currentPage,currentType
Private cacheName,labelRule,regExpObj,strDictionary
Public Sub Class_Initialize()
set regExpObj= new RegExp
regExpObj.ignoreCase=true
regExpObj.Global=true
set strDictionary=server.CreateObject(DICTIONARY_OBJ_NAME)
End Sub
Public Sub Class_Terminate()
set regExpObj=nothing
set strDictionary=nothing
End Sub
Public Function load(Byval filePath)
cacheName="template_"&filePath
if(clng(cacheStart)=1) then
if (cacheObj.chkCache(cacheName)) then content=cacheObj.getCache(cacheName) else content=loadFile(filePath):cacheObj.setCache cacheName,content
else
content=loadFile(filePath)
end if
End Function
Public Function parseSelf()
if not isExistStr(content,"{self:") then Exit Function
dim matches,match,labelName,selfLabelArray,selfLabelLen,sql,singleAttrKey,singleAttrValue
sql="select m_name,m_content from {pre}selflabel"
labelRule="{self:([\s\S]+?)}"
if cacheStart=1 then
if (not cacheObj.chkCache("array_allselflabel_name_content")) then selfLabelArray=conn.db(sql,"array") : cacheObj.setCache "array_allselflabel_name_content",selfLabelArray else selfLabelArray=cacheObj.getCache("array_allselflabel_name_content")
else
selfLabelArray=conn.db(sql,"array")
end if
if isArray(selfLabelArray) then
for selfLabelLen=0 to ubound(selfLabelArray,2)
singleAttrKey=selfLabelArray(0,selfLabelLen)
singleAttrValue=decodeHtml(selfLabelArray(1,selfLabelLen))
dim singleLength : singleLength=Ubound(split(singleAttrValue,"$$$"))
randomize : dim singleNum : singleNum=clng((singleLength)*rnd)
if singleLength>0 then
singleAttrValue=split(singleAttrValue,"$$$")(singleNum)
end if
if not strDictionary.Exists(singleAttrKey) then strDictionary.add singleAttrKey,singleAttrValue else strDictionary(singleAttrKey)=singleAttrValue
next
end if
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
labelName=trim(match.SubMatches(0))
if strDictionary.Exists(labelName) then content=replace(content,match.value,strDictionary(labelName))
next
strDictionary.RemoveAll
set matches=nothing
End Function
Public Function parseTopAndFoot()
content=replaceStr(content,"{maxcms:top}",loadFileOnCache("template_","/"&sitePath&"template/"&defaultTemplate&"/"&templateFileFolder&"/head.html"))
content=replaceStr(content,"{maxcms:foot}",loadFileOnCache("template_","/"&sitePath&"template/"&defaultTemplate&"/"&templateFileFolder&"/foot.html"))
content=replaceStr(content,"images/","/"&sitePath&"template/"&defaultTemplate&"/images/")
if gbookStart=0 then
content=replaceStr(content,"{maxcms:gbook}","")
else
content=replaceStr(content,"{maxcms:gbook}","留言求片")
end if
End Function
Public Function parseGlobal()
if isExistStr(content,"{maxcms:letterlist}") then content=replaceStr(content,"{maxcms:letterlist}",getletterlist)
if isExistStr(content,"{maxcms:indexlink}") then content=replaceStr(content,"{maxcms:indexlink}",getIndexLink)
if isExistStr(content,"{maxcms:topiclink}") then content=replaceStr(content,"{maxcms:topiclink}",getTopicIndexLink)
if isExistStr(content,"{maxcms:newslink}") then content=replaceStr(content,"{maxcms:newslink}",getNewsChannelLink(1))
content=replaceStr(content,"{maxcms:siteurl}",siteUrl)
content=replaceStr(content,"{maxcms:sitepath}",sitePath)
content=replaceStr(content,"{maxcms:adfolder}",siteAd)
content=replaceStr(content,"{maxcms:sitename}",siteName)
content=replaceStr(content,"{maxcms:copyright}",decodeHtml(copyRight))
content=replaceStr(content,"{maxcms:des}",decodeHtml(siteDes))
content=replaceStr(content,"{maxcms:sitevisitjs}",siteVisiteJs)
content=replaceStr(content,"{maxcms:sitenotice}",decodeHtml(siteNotice))
content=replaceStr(content,"{maxcms:keywords}",getKeywordsList(siteKeyWords,""))
if isExistStr(content,"{maxcms:allcount}") then content=replaceStr(content,"{maxcms:allcount}",getDataCount("all"))
if isExistStr(content,"{maxcms:daycount}") then content=replaceStr(content,"{maxcms:daycount}",getDataCount("day"))
if gbookStart=0 then content=replaceStr(content,"{maxcms:gbook}","") else content=replaceStr(content,"{maxcms:gbook}","留言求片")
parseSlide
if runMode="static" then content=replaceStr(content,"{maxcms:runinfo}","")
End Function
Public Function parseAttr(Byval attr)
dim attrStr,attrArray,attrDictionary,i,singleAttr,singleAttrKey,singleAttrValue
attrStr=regExpReplace(attr,"[\s]+",chr(32))
attrStr=trimOuter(attrStr)
attrArray=split(attrStr,chr(32))
for i=0 to ubound(attrArray)
singleAttr=split(attrArray(i),chr(61))
singleAttrKey= singleAttr(0) : singleAttrValue= singleAttr(1)
if not strDictionary.Exists(singleAttrKey) then strDictionary.add singleAttrKey,singleAttrValue else strDictionary(singleAttrKey)=singleAttrValue
next
set parseAttr=strDictionary
End Function
Public Function regExpReplace(contentstr,patternstr,replacestr)
regExpObj.Pattern=patternstr
regExpReplace=regExpObj.replace(contentstr,replacestr)
End Function
Public Function parseAreaList()
if not isExistStr(content,"{maxcms:arealist") then Exit Function
dim matches,match,matchesVideolist,matchVideolist,totalStrAreaList,singleStrAreaList
dim labelAttrArealist,loopStrArealist,currentAreaType,areaType,areaTypeArray
dim labelAttrVideolist,labelVideolist,labelRuleVideolist,videoListStr
dim i,j,sql,typeStr,letterHas,TS,m:typeStr="":TS=getTypeLists():j=getTypeIndex("m_upid"):m=getTypeIndex("m_id")
labelRule="{maxcms:arealist([\s\S]*?)}([\s\S]*?){/maxcms:arealist}"
labelRuleVideolist="{maxcms:videolist([\s\S]*?)}([\s\S]*?){/maxcms:videolist}"
for i=0 to UBound(TS,2)
if ""&TS(j,i)="0" then
if typeStr="" then
typeStr=TS(m,i)
else
typeStr=typeStr&","&TS(m,i)
end if
end if
next
regExpObj.Pattern=labelRule:set matches=regExpObj.Execute(content)
for each match in matches
if typeStr<>"" then
labelAttrArealist=match.SubMatches(0)
loopStrArealist=match.SubMatches(1)
areaType=parseAttr(labelAttrArealist)("areatype")
letterHas=parseAttr(labelAttrArealist)("arealetter")
if not isNul(letterHas) then areaType="letter"
if isNul(areaType) then areaType="all"
if areaType="letter" then
if isNul(letterHas) OR letterHas="all" then letterHas="A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
letterHas=Split(letterHas,",")
for j=0 to UBound(letterHas)
if letterHas(j)<>"" then
singleStrAreaList=loopStrArealist
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:i]",j+1)
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:typename]",letterHas(j))
if isExistStr(singleStrAreaList,"[arealist:count]") then
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:count]",conn.db("SELECT COUNT(*) FROM {pre}data WHERE m_letter='"&letterHas(j)&"'","execute")(0))
end if
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:link]","/"&sitepath&"search.asp?searchtype=4&searchword="&letterHas(j))
regExpObj.Pattern=labelRuleVideolist
set matchesVideolist=regExpObj.Execute(singleStrAreaList)
for each matchVideolist in matchesVideolist
videoListStr=replaceStr(matchVideolist.value,"arealetter",letterHas(j))
videoListStr=replaceStr(videoListStr,"areatype","all")
singleStrAreaList=replaceStr(singleStrAreaList,matchVideolist.value,videoListStr)
next
set matchesVideolist=nothing
totalStrAreaList=totalStrAreaList&singleStrAreaList
end if
next
else
if areaType="all" then:areaTypeArray=split(typeStr,","):else:areaTypeArray=split(areaType,","):end if
for j=0 to ubound(areaTypeArray)
currentAreaType=areaTypeArray(j)
if not isNum(currentAreaType) then die err_areaList
m=Split(getTypeNameTemplateArrayOnCache(currentAreaType),",") : if UBound(m)=-1 then Exit For
singleStrAreaList=loopStrArealist
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:i]",j+1)
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:typename]",m(0))
if isExistStr(singleStrAreaList,"[arealist:count]") then
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:count]",getNumPerType(currentAreaType))
end if
singleStrAreaList=replaceStr(singleStrAreaList,"[arealist:link]",getTypeLink(currentAreaType))
regExpObj.Pattern=labelRuleVideolist
set matchesVideolist=regExpObj.Execute(singleStrAreaList)
for each matchVideolist in matchesVideolist
videoListStr=replaceStr(matchVideolist.value,"arealetter","all")
videoListStr=replaceStr(videoListStr,"areatype",currentAreaType)
singleStrAreaList=replaceStr(singleStrAreaList,matchVideolist.value,videoListStr)
next
set matchesVideolist=nothing
totalStrAreaList=totalStrAreaList&singleStrAreaList
next
end if
else
totalStrAreaList=""
end if
content=replaceStr(content,match.value,totalStrAreaList)
totalStrAreaList=""
next
set matches=nothing
End Function
Public Function parseVideoList()
if not isExistStr(content,"{maxcms:videolist") then Exit Function
dim match,matches,matchfield,matchesfield
dim labelAttrVideolist,loopstrVideoList,loopstrVlistNew,loopstrTotal,attrDictionary
dim vnum,vorder,vtype,vtopic,vtime,vstart,vstate,vcommend,vletter
dim fieldName,fieldAttr,fieldNameAndAttr,fieldAttrLen
dim i,labelRuleField,field_des,field_playdata,n : n=0
dim namelen,actorlen,deslen,timestyle,videoTime,colornamelen,m_colorname,m_des,m_color,m_note,notelen,m_name,m_actor
dim m,sql,orderStr,whereType,whereLetter,whereTopic,whereTime,whereStr,videoListArray,whereState,whereCommend,vtypeArray,vtypeI,vtypeStr,vtypeArrayLen,playlink_str
labelRule="{maxcms:videolist([\s\S]*?)}([\s\S]*?){/maxcms:videolist}"
labelRuleField="\[videolist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
labelAttrVideolist=match.SubMatches(0)
loopstrVideoList=match.SubMatches(1)
if isExistStr(loopstrVideoList,"[videolist:des") then field_des="m_des" else field_des="0"
if isExistStr(loopstrVideoList,"[videolist:from]") then field_playdata="m_playdata" else field_playdata="0"
set attrDictionary=parseAttr(labelAttrVideolist)
vnum=attrDictionary("num") : vorder=attrDictionary("order") : vletter=attrDictionary("letter"):vtype=attrDictionary("type") : vtopic=attrDictionary("topic") : vtime=attrDictionary("time") : vstart=attrDictionary("start") : vstate=attrDictionary("state") : vcommend=attrDictionary("commend")
if isNul(vnum) then vnum=10 else vnum=clng(vnum)
if isNul(vorder) then vorder="time"
select case vorder
case "id" : orderStr =" order by m_id desc"
case "hit" : orderStr =" order by m_hit desc"
case "time" : orderStr =" order by m_addtime desc"
case "commend" : orderStr =" order by m_commend desc"
case "digg" : orderStr =" order by m_digg desc"
case "hot" : orderStr =" order by m_hit desc"
case "random"
if databaseType=0 then
dim rndNum:randomize() : rndNum=int(1000*rnd)+1 : orderStr =" order by rnd( -1*"&rndNum&" * m_id)"
else
orderStr=" order by newid() desc"
end if
end select
if isNul(vtype) then vtype="all"
vtypeStr=""
if vtype <> "all" then
if vtype="current" then
vtypeStr=getTypeIdOnCache(currentTypeId)
else
if instr(vtype,",")>0 then
vtypeArray=split(vtype,","):vtypeArrayLen=ubound(vtypeArray)
for vtypeI=0 to vtypeArrayLen
vtypeStr=vtypeStr&getTypeIdOnCache(vtypeArray(vtypeI))&","
next
vtypeStr=trimOuterStr(vtypeStr,",")
else
vtypeStr=getTypeIdOnCache(vtype)
end if
end if
if InStr(vtypeStr,",")>0 then:whereType=" and m_type in ("&vtypeStr&") ":else:whereType=" and m_type="&vtypeStr:end if
else
whereType=""
end if
if not Isnul(vletter) AND vletter<>"all" then whereLetter=" and m_letter ='"&UCase(vletter)&"' " else whereLetter=""
if vstate="series" then whereState=" and m_state>0" else whereState=""
if not isNul(vcommend) then
select case trim(vcommend)
case "all" : whereCommend=" and m_commend>0"
case else
if instr(vcommend,",")>0 then whereCommend=" and m_commend in("&vcommend&")" else whereCommend=" and m_commend ="&vcommend
end select
else
whereCommend=""
end if
if not isNul(vtopic) then
select case trim(vtopic)
case "all" : whereTopic=" and m_topic>0"
case "current" : whereTopic=" and m_topic="¤tTopicId
case else
if instr(vtopic,",")>0 then whereTopic=" and m_topic in("&vtopic&")" else whereTopic=" and m_topic ="&vtopic
end select
else
whereTopic=""
end if
if databaseType = 0 then
select case vtime
case "day" : whereTime=" and DateDiff('d',m_addtime,#"&now()&"#)=0"
case "week" : whereTime=" and DateDiff('d',m_addtime,#"&now()&"#)<7"
case "month" : whereTime=" and DateDiff('d',m_addtime,#"&now()&"#)<31"
case else : whereTime=""
end select
else
select case vtime
case "day" : whereTime=" and DateDiff(d,m_addtime,'"&now()&"')=0"
case "week" : whereTime=" and DateDiff(d,m_addtime,'"&now()&"')<7"
case "month" : whereTime=" and DateDiff(d,m_addtime,'"&now()&"')<31"
case else : whereTime=""
end select
end if
whereStr=Replace(" where "&whereType&whereLetter&whereTopic&whereTime&whereState&whereCommend,"where and ","where ")
if trim(whereStr)="where" then whereStr=""
if not isNul(vstart) then vstart=clng(vstart) else vstart=1
n=vstart-1 : vnum=vnum+vstart-1
set attrDictionary=nothing
sql="select top "&vnum+1&" m_id,m_name,m_type,m_state,m_pic,m_hit,m_actor,"&field_des&",m_topic,m_color,m_addtime,m_publishyear,m_publisharea ,m_commend,"&field_playdata&",m_note,m_letter from {pre}data "&whereStr&orderStr
conn.fetchCount=vnum:videoListArray=conn.db(sql,"array"):conn.fetchCount=0
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrVideoList)
loopstrTotal=""
if isArray(videoListArray) then vnum=ubound(videoListArray,2) else vnum=-1
for i=n to vnum
loopstrVlistNew=loopstrVideoList
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "id"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(0,i))
case "typeid"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(2,i))
case "letter"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(16,i))
case "name"
m_name=videoListArray(1,i):namelen=parseAttr(fieldAttr)("len")
if not isNul(namelen) and len(m_name)>clng(namelen) then m_name=left(m_name,clng(namelen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_name)
case "colorname"
m_color=videoListArray(9,i):m_name=videoListArray(1,i):colornamelen=parseAttr(fieldAttr)("len")
if not isNul(colornamelen) and len(m_name)>clng(colornamelen) then m_name=left(m_name,clng(colornamelen)-1)&".."
if not(isnul(m_color)) then m_name=""&m_name&""
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_name)
case "note"
m_note=videoListArray(15,i) : notelen=parseAttr(fieldAttr)("len")
if not isNul(notelen) and len(m_note) > clng(notelen) then m_note=left(m_note,clng(notelen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_note)
case "actor"
m_actor=videoListArray(6,i) : actorlen=parseAttr(fieldAttr)("len")
if not isNul(actorlen) and len(m_actor) > clng(actorlen) then m_actor=left(m_actor,clng(actorlen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_actor)
case "des"
m_des=filterStr(decodeHtml(videoListArray(7,i)),"html"):deslen=parseAttr(fieldAttr)("len")
if isNul(deslen) then deslen=200
if len(m_des) > clng(deslen) then m_des=left(m_des,clng(deslen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_des)
case "time"
timestyle=parseAttr(fieldAttr)("style") : if isNul(timestyle) then timestyle="m-d"
videoTime=videoListArray(10,i)
dim monthDayTime : if month(videoTime)<10 then monthDayTime="0"&month(videoTime) else monthDayTime = month(videoTime)
if day(videoTime)<10 then monthDayTime=monthDayTime&"-0"&day(videoTime) else monthDayTime=monthDayTime&"-"&day(videoTime)
select case timestyle
case "yyyy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(videoTime)&"-"&monthDayTime)
case "yy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,right(year(videoTime),2)&"-"&monthDayTime)
case "yyyy-m-d"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(videoTime)&"-"&month(videoTime)&"-"&day(videoTime))
case else
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,monthDayTime)
end select
case "i"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,i+1)
case "typename"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,split(getTypeNameTemplateArrayOnCache(clng(videoListArray(2,i))),",")(0))
case "typelink"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,getTypeLink(videoListArray(2,i)))
case "link"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,getContentLink(videoListArray(2,i),videoListArray(0,i),"link"))
case "playlink"
if isAlertWin=1 then playlink_str="javascript:openWin('"&getPlayLink2(videoListArray(2,i),videoListArray(0,i))&"',"&(alertWinW+10)&","&(alertWinH+55)&",250,100,1)" else playlink_str=getPlayLink2(videoListArray(2,i),videoListArray(0,i))
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,playlink_str)
case "pic"
if not isNul(videoListArray(4,i)) then
if instr(videoListArray(4,i),"http://")>0 then
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(4,i))
else
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,"/"&sitePath&videoListArray(4,i))
end if
else
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,"/"&sitePath&"pic/nopic.gif")
end if
case "hit"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(5,i))
case "state"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(3,i))
case "publishtime"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(11,i))
case "publisharea"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(12,i))
case "commend"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,videoListArray(13,i))
case "from"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,replaceStr(getFromStr(videoListArray(14,i)),"播客CC","FLV高清"))
end select
strDictionary.removeAll
next
loopstrTotal=loopstrTotal&loopstrVlistNew
next
set matchesfield=nothing
content=replaceStr(content,match.value,loopstrTotal)
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function parsePageList(typeId,currentPage,totalPages,pageListType)
dim matchChannel,matchesChannel,loopstrChannel,loopstrTotal,attrChannel,attrDictionary,loopstrChannelNew
dim labelRuleField,field_des,field_playdata
dim vsize,vorder
dim i,m,sql,rsObj,orderStr,whereStr
dim matchfield,matchesfield,fieldNameAndAttr,fieldName,fieldAttr
dim namelen,actorlen,deslen,timestyle,videoTime,colornamelen,m_colorname,m_des,m_color,m_note,notelen,m_actor,m_name
dim matchPagelist,matchesPagelist,labelRulePagelist,lenPagelist,strPagelist,playlink_str
labelRule="{maxcms:"&pageListType&"list([\s\S]*?)}([\s\S]*?){/maxcms:"&pageListType&"list}"
labelRuleField="\["&pageListType&"list:([\s\S]+?)\]"
labelRulePagelist="\["&pageListType&"list:pagenumber([\s\S]*?)\]"
if isExistStr(content,"["&pageListType&"list:des") then field_des="m_des" else field_des="0"
if isExistStr(content,"["&pageListType&"list:from]") then field_playdata="m_playdata" else field_playdata="0"
regExpObj.Pattern=labelRule
set matchesChannel=regExpObj.Execute(content)
for each matchChannel in matchesChannel
attrChannel=matchChannel.SubMatches(0)
loopstrChannel=matchChannel.SubMatches(1)
set attrDictionary=parseAttr(attrChannel)
vsize=clng(attrDictionary("size")) : vorder=attrDictionary("order")
if isNul(vsize) then vsize=12
if isNul(vorder) then vorder="time"
select case vorder
case "id" : orderStr =" order by m_id desc"
case "hit" : orderStr =" order by m_hit desc"
case "time" : orderStr =" order by m_addtime desc"
case "hot" : orderStr =" order by m_hit desc"
case "digg" : orderStr =" order by m_digg desc"
case "name" : orderstr=" order by m_name asc "
case "letter" : orderstr=" order by m_letter asc"
end select
set attrDictionary=nothing
select case pageListType
case "channel"
sql="select m_id,m_name,m_type,m_state,m_pic,m_hit,m_actor,"&field_des&",m_topic,m_color,m_addtime,m_publishyear,m_publisharea,m_commend,"&field_playdata&",m_note from {pre}data where m_type in ("&typeId&")"&orderStr
case "search"
select case clng(searchType)
case -1 : whereStr=" where m_name like '%"&searchword&"%' or m_actor like '%"&searchword&"%' or m_publisharea like '%"&searchword&"%' or m_publishyear like '%"&searchword&"%'"
case 0 : whereStr=" where m_name like '%"&searchword&"%'"
case 1 : whereStr=" where m_actor like '%"&searchword&"%'"
case 2 : whereStr=" where m_publisharea like '%"&searchword&"%'"
case 3 : whereStr=" where m_publishyear like '%"&searchword&"%'"
case 4 : whereStr=" where m_letter='"&UCase(searchword)&"'"
end select
sql="select m_id,m_name,m_type,m_state,m_pic,m_hit,m_actor,"&field_des&",m_topic,m_color,m_addtime,m_publishyear,m_publisharea,m_commend,"&field_playdata&",m_note from {pre}data "&whereStr&orderStr
case "topicpage"
Sql="select m_id,m_name,m_type,m_state,m_pic,m_hit,m_actor,"&field_des&",m_topic,m_color,m_addtime,m_publishyear,m_publisharea,m_commend,"&field_playdata&",m_note from {pre}data where m_topic="&typeId&orderStr
end select
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrChannel)
set rsObj=conn.db(sql,"records1")
if rsObj.eof then
if pageListType="channel" then
loopstrTotal=channellistInfo(0)
elseif pageListType="search" then
loopstrTotal=searchlistInfo(0)&searchword&searchlistInfo(1)
elseif pageListType="topicpage" then
loopstrTotal=topicpageInfo(0)
end if
else
rsObj.pagesize=vsize
if clng(currentPage)>clng(rsObj.pagecount) then currentPage=rsObj.pagecount
rsObj.absolutepage=currentPage
loopstrTotal=""
for i=1 to vsize
loopstrChannelNew=loopstrChannel
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "id"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(0))
case "typeid"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(2))
case "name"
m_name=rsObj(1):namelen=parseAttr(fieldAttr)("len")
if not isNul(namelen) and len(m_name)>clng(namelen) then m_name=left(m_name,clng(namelen)-1)&".."
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,m_name)
case "colorname"
m_color=rsObj(9):m_name=rsObj(1):colornamelen=parseAttr(fieldAttr)("len")
if not isNul(colornamelen) and len(m_name)>clng(colornamelen) then m_name=left(m_name,clng(colornamelen)-1)&".."
if not(isnul(m_color)) then m_name=""&m_name&""
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,m_name)
case "note"
m_note=rsObj(15) : notelen=parseAttr(fieldAttr)("len")
if not isNul(notelen) and len(m_note) > clng(notelen) then m_note=left(m_note,clng(notelen)-1)&".."
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,m_note)
case "actor"
m_actor=rsObj(6) : actorlen=parseAttr(fieldAttr)("len")
if not isNul(actorlen) and len(m_actor) > clng(actorlen) then m_actor=left(m_actor,clng(actorlen)-1)&".."
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,m_actor)
case "des"
m_des=filterStr(decodeHtml(rsObj(7)),"html"):deslen=parseAttr(fieldAttr)("len")
if isNul(deslen) then deslen=200
if len(m_des) > clng(deslen) then m_des=left(m_des,clng(deslen)-1)&".."
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,m_des)
case "time"
timestyle=parseAttr(fieldAttr)("style") : if isNul(timestyle) then timestyle="m-d"
videoTime=rsObj(10)
dim monthDayTime : if month(videoTime)<10 then monthDayTime="0"&month(videoTime) else monthDayTime = month(videoTime)
if day(videoTime)<10 then monthDayTime=monthDayTime&"-0"&day(videoTime) else monthDayTime=monthDayTime&"-"&day(videoTime)
select case timestyle
case "yyyy-mm-dd"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,year(videoTime)&"-"&monthDayTime)
case "yy-mm-dd"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,right(year(videoTime),2)&"-"&monthDayTime)
case "yyyy-m-d"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,year(videoTime)&"-"&month(videoTime)&"-"&day(videoTime))
case else
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,monthDayTime)
end select
case "i"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,i)
case "typename"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,split(getTypeNameTemplateArrayOnCache(rsObj(2)),",")(0))
case "typelink"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,getTypeLink(rsObj(2)))
case "link"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,getContentLink(rsObj(2),rsObj(0),"link"))
case "playlink"
if isAlertWin=1 then playlink_str="javascript:openWin('"&getPlayLink2(rsObj(2),rsObj(0))&"',"&(alertWinW+10)&","&(alertWinH+55)&",250,100,1)" else playlink_str=getPlayLink2(rsObj(2),rsObj(0))
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,playlink_str)
case "pic"
if not isNul(rsObj(4)) then
if instr(rsObj(4),"http://")>0 then
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(4))
else
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,"/"&sitePath&rsObj(4))
end if
else
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,"/"&sitePath&"pic/nopic.gif")
end if
case "hit"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(5))
case "state"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(3))
case "publishtime"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(11))
case "publisharea"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(12))
case "commend"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,rsObj(13))
case "from"
loopstrChannelNew=replaceStr(loopstrChannelNew,matchfield.value,replaceStr(getFromStr(rsObj(14)),"播客CC","FLV高清"))
end select
strDictionary.removeAll
next
loopstrTotal=loopstrTotal&loopstrChannelNew
rsObj.movenext
if rsObj.eof then exit for
next
end if
content=replace(content,matchChannel.value,loopstrTotal)
regExpObj.Pattern=labelRulePagelist
set matchesPagelist=regExpObj.Execute(content)
for each matchPagelist in matchesPagelist
if rsObj.pagecount=0 then
content=replace(content,matchPagelist.value,"")
else
lenPagelist=parseAttr(matchPagelist.SubMatches(0))("len")
if isNul(lenPagelist) then lenPagelist=10 else lenPagelist=clng(lenPagelist)
strPagelist=pageNumberLinkInfo(currentPage,lenPagelist,rsObj.pagecount,pageListType,rsObj.recordcount)
content=replace(content,matchPagelist.value,strPagelist)
end if
next
set matchesPagelist=nothing
set matchesfield=nothing
strDictionary.removeAll
next
set matchesChannel=nothing
End Function
Public Function getMenuArray(ByVal sId,ByVal m)
Dim i,j,k,l,h,vnum,rsArray,typeArray:vnum=-1:typeArray=getTypeLists():j=getTypeIndex("m_id"):k=getTypeIndex("m_name"):l=getTypeIndex("m_upid"):h=getTypeIndex("m_hide")
if m="m_id" then:m=j:else:m=l:end if
for i=0 to UBound(typeArray,2)
if InStr(" ,"&sId&",",","&typeArray(m,i)&",")>0 AND ""&typeArray(h,i)="0" then
vnum=vnum+1
if not isArray(rsArray) then
Redim rsArray(2,vnum)
else
Redim preserve rsArray(2,vnum)
end if
rsArray(0,vnum)=typeArray(k,i)
rsArray(1,vnum)=typeArray(j,i)
rsArray(2,vnum)=typeArray(l,i)
end if
next
getMenuArray=rsArray
End Function
Public Function parseMenuList(str)
dim match,matches,matchfield,matchesfield
dim labelAttrMenulist,loopstrMenulist,loopstrMlistNew,loopstrTotal
dim vtype,vnum,vnumSon,curUpId,curUpIdStr,curUpIdStrArray
dim fieldName,fieldAttr,fieldNameAndAttr,fieldAttrLen
dim i,labelRuleField
dim m,rsArray,rsFlag
labelRule="{maxcms:"&str&"menulist([\s\S]*?)}([\s\S]*?){/maxcms:"&str&"menulist}"
labelRuleField="\["&str&"menulist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
loopstrTotal=""
labelAttrMenulist=match.SubMatches(0)
loopstrMenulist=match.SubMatches(1)
vtype=parseAttr(labelAttrMenulist)("type")
if isNul(vtype) then vtype="top"
select case vtype
case "top"
rsFlag="top":rsArray=getMenuArray("0","m_upid")
if isArray(rsArray) then:vnum=UBound(rsArray,2):else:vnum=-1:end if
case "son"
rsFlag="son"
curUpIdStr=getTypeNameTemplateArrayOnCache(clng(currentTypeId)):curUpIdStrArray=split(curUpIdStr,",")
if ubound(curUpIdStrArray)=2 then curUpId=trim(curUpIdStrArray(2)) else curUpId=-444
if clng(curUpId)<>0 then
rsArray=getMenuArray(curUpId,"m_upid")
else
rsArray=getMenuArray(trim(currentTypeId),"m_upid")
end if
if isArray(rsArray) then:vnum=UBound(rsArray,2):else:vnum=-1:end if
case "all"
rsFlag="all" : vnum=-1 : loopstrTotal=getAllMenuListOnCache(0)
case else
vtype=split(vtype,",")
for i=0 to ubound(vtype)
vtype(i)=trim(vtype(i))
if not isnum(vtype(i)) then die channellistInfo(1)
next
vtype=Join(vtype,",")
if isNul(str) then
rsArray=getMenuArray(vtype,"m_id")
else
rsArray=getMenuArray(vtype,"m_upid")
end if
if isArray(rsArray) then:vnum=UBound(rsArray,2):else:vnum=-1:end if
end select
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrMenulist)
for i=0 to vnum
loopstrMlistNew=loopstrMenulist
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "i"
loopstrMlistNew=replaceStr(loopstrMlistNew,matchfield.value,i+1)
case "typeid"
loopstrMlistNew=replaceStr(loopstrMlistNew,matchfield.value,rsArray(1,i))
case "typename"
loopstrMlistNew=replaceStr(loopstrMlistNew,matchfield.value,rsArray(0,i))
case "upid"
loopstrMlistNew=replaceStr(loopstrMlistNew,matchfield.value,rsArray(2,i))
case "link"
loopstrMlistNew=replaceStr(loopstrMlistNew,matchfield.value,getTypeLink(rsArray(1,i)))
end select
next
loopstrTotal=loopstrTotal&loopstrMlistNew
next
set matchesfield=nothing
content=replaceStr(content,match.value,loopstrTotal)
strDictionary.removeAll
next
set matches=nothing
if isExistStr(content,"{maxcms:smallmenulist") then parseMenuList "small" else Exit Function
End Function
Function replaceTopicId()
content=replace(content,"{maxcms:currrent_topic_id}",currrent_topic_id)
End Function
Public Function parseTopicList()
if not isExistStr(content,"{maxcms:topiclist") then Exit Function
dim match,matches,matchfield,matchesfield
dim labelAttrTopiclist,loopstrTopiclist,loopstrTopiclistNew,loopstrTotal
dim vtid,vnum
dim fieldName,fieldAttr,fieldNameAndAttr,fieldAttrLen
dim i,labelRuleField
dim m,rsArray,rsFlag,whereTopic,topicLink
labelRule="{maxcms:topiclist([\s\S]*?)}([\s\S]*?){/maxcms:topiclist}"
labelRuleField="\[topiclist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
loopstrTotal=""
labelAttrTopiclist=match.SubMatches(0)
loopstrTopiclist=match.SubMatches(1)
vtid=parseAttr(labelAttrTopiclist)("id")
if isNul(vtid) then vtid="all"
select case trim(vtid)
case "all" : whereTopic=""
case else
if instr(vtid,",")>0 then whereTopic=" where m_id in("&vtid&")" else whereTopic=" where m_id ="&vtid
end select
rsArray=conn.db("select m_name,m_id,m_pic,m_enname,m_des,(select count(*) from {pre}data where m_topic=t.m_id) as m_count from {pre}topic as t"&whereTopic&" order by m_sort asc","array")
if isArray(rsArray) then vnum=ubound(rsArray,2) else vnum=-1
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrTopiclist)
for i=0 to vnum
loopstrTopiclistNew=loopstrTopiclist
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "i"
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,i+1)
case "name"
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,rsArray(0,i))
case "count"
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,rsArray(5,i))
case "pic"
if not isNul(rsArray(2,i)) then
if instr(rsArray(2,i),"http://")>0 then
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,rsArray(2,i))
else
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,"/"&sitePath&"pic/zt/"&rsArray(2,i))
end if
else
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,"/"&sitePath&"pic/nopic.gif")
end if
case "link"
if runMode="dynamic" then
topicLink="/"&sitePath&topicDirName&"/?"&rsArray(1,i)&fileSuffix
elseif runMode="static" then
topicLink="/"&sitePath&topicDirName&"/"&rsArray(3,i)&fileSuffix
elseif runMode="forgedStatic" then
topicLink="/"&sitePath&topicDirName4&"/"&rsArray(1,i)&fileSuffix
end if
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,topicLink)
case "des"
dim deslen,m_des:m_des=decodeHtml(rsArray(4,i)):deslen=parseAttr(fieldAttr)("len")
if isNul(deslen) then deslen=200
if len(m_des) > clng(deslen) then m_des=left(m_des,clng(deslen)-1)&".."
loopstrTopiclistNew=replaceStr(loopstrTopiclistNew,matchfield.value,m_des)
end select
next
loopstrTotal=loopstrTotal&loopstrTopiclistNew
next
set matchesfield=nothing
content=replaceStr(content,match.value,loopstrTotal)
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function parseLinkList()
if not isExistStr(content,"{maxcms:linklist") then Exit Function
dim match,matches,matchfield,matchesfield
dim labelAttrLinklist,loopstrLinklist,loopstrLinklistNew,loopstrTotal
dim vtype,vnum,whereStr,linkArray
dim fieldName,fieldAttr,fieldNameAndAttr,fieldAttrLen
dim i,labelRuleField
dim m,namelen,deslen,m_des
labelRule="{maxcms:linklist([\s\S]*?)}([\s\S]*?){/maxcms:linklist}"
labelRuleField="\[linklist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
labelAttrLinklist=match.SubMatches(0)
loopstrLinklist=match.SubMatches(1)
vtype=parseAttr(labelAttrLinklist)("type")
if isNul(vtype) then vtype="font"
select case vtype
case "font" : whereStr=chr(32)&"m_type='font'"&chr(32)
case "pic" : whereStr=chr(32)&"m_type='pic'"&chr(32)
case else : whereStr=chr(32)&"m_type='font'"&chr(32)
end select
linkArray=conn.db("select m_name,m_pic,m_url,m_des from {pre}link where "&whereStr&" order by m_sort asc","array")
if not isarray(linkArray) then vnum=-1 else vnum=ubound(linkArray,2)
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrLinklist)
loopstrTotal=""
for i=0 to vnum
loopstrLinklistNew=loopstrLinklist
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "name"
namelen=parseAttr(fieldAttr)("len") : if isNul(namelen) then namelen=8 else namelen=clng(namelen)
loopstrLinklistNew=replaceStr(loopstrLinklistNew,matchfield.value,left(linkArray(0,i),namelen))
case "link"
loopstrLinklistNew=replaceStr(loopstrLinklistNew,matchfield.value,linkArray(2,i))
case "pic"
loopstrLinklistNew=replaceStr(loopstrLinklistNew,matchfield.value,linkArray(1,i))
case "des"
m_des=decodeHtml(linkArray(3,i)):deslen=parseAttr(fieldAttr)("len")
if isNul(deslen) then deslen=100
if len(m_des) > clng(deslen) then m_des=left(m_des,clng(deslen)-1)&".."
loopstrLinklistNew=replaceStr(loopstrLinklistNew,matchfield.value,m_des)
case "i"
loopstrLinklistNew=replaceStr(loopstrLinklistNew,matchfield.value,i+1)
end select
next
loopstrTotal=loopstrTotal&loopstrLinklistNew
next
set matchesfield=nothing
content=replaceStr(content,match.value,loopstrTotal)
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function parsePlayList(dataId,typeid,playORdownData,str)
if not isExistStr(content,"{playpage:playlist") and not isExistStr(content,"{playpage:downlist") then Exit Function
dim match,matches,matchfield,matchesfield
dim loopstrPlaylist,loopstrPlaylistNew,loopstrTotal
dim vtype,playRsArray,playDataArray,singlePlayData,vnum,videoFrom,videoUrl
dim fieldName,fieldAttr,fieldNameAndAttr
dim i,j,labelRuleField,i_2,PlayerIntroArray:PlayerIntroArray=getPlayerIntroArrayOnCache(str)
dim m,videoFromStr,videoFromCount,whereStr,n,urlStr,playerInfoStr,playerSingleInfoArray
labelRule="{playpage:"&str&"list[\s\S]*?}([\s\S]*?){/playpage:"&str&"list}"
labelRuleField="\["&str&"list:([\s\S]+?)\]"
'whereStr =chr(32)&"m_id="&dataId&chr(32)
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
loopstrPlaylist=match.SubMatches(0)
'playRsArray=conn.db("select m_type,m_"&str&"data from {pre}data where "&whereStr,"array")
'playDataArray=getPlayurlArray(playRsArray(1,0))
playDataArray=getPlayurlArray(playORdownData)
vnum=ubound(playDataArray)
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrPlaylist)
i_2=0:ReDim loopstrTotal(UBound(PlayerIntroArray,2))
for i=0 to vnum
singlePlayData=split(playDataArray(i),"$$") : videoFrom=i : videoUrl=singlePlayData(1)
playerInfoStr=getPlayerIntroOnCache(str,singlePlayData(0))
if isExistStr(playerInfoStr,"__maxcc__") then
playerSingleInfoArray=split(playerInfoStr,"__maxcc__")
loopstrPlaylistNew=loopstrPlaylist
if playerSingleInfoArray(1)="1" then
'i_2=i_2+1
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "from"
loopstrPlaylistNew=replace(replace(loopstrPlaylistNew,matchfield.value,singlePlayData(0)),"播客CC","FLV高清")
case "intro"
loopstrPlaylistNew=replace(loopstrPlaylistNew,matchfield.value,playerSingleInfoArray(0))
case "link"
'urlStr=getPlayUrlList(videoFrom,videoUrl,playRsArray(0,0),dataId,str,parseAttr(fieldAttr)("target"))
urlStr=getPlayUrlList(videoFrom,videoUrl,typeid,dataId,str,parseAttr(fieldAttr)("target"))
loopstrPlaylistNew=replace(loopstrPlaylistNew,matchfield.value,urlStr)
case "i"
'loopstrPlaylistNew=replace(loopstrPlaylistNew,matchfield.value,i_2)
end select
next
else
loopstrPlaylistNew=""
end if
else
loopstrPlaylistNew=""
end if
j=getArrayElementID(PlayerIntroArray,0,singlePlayData(0)):m=loopstrTotal(j)
if not isArray(m) then Redim m(-1)
Redim preserve m(UBound(m)+1)
m(UBound(m))=loopstrPlaylistNew:loopstrTotal(j)=m
next
set matchesfield=nothing
for i=0 to UBound(loopstrTotal)
if isArray(loopstrTotal(i)) then
for j=0 to UBound(loopstrTotal(i))
i_2=i_2+1:loopstrTotal(i)(j)=Replace(loopstrTotal(i)(j),"["&str&"list:i]",i_2)
next
loopstrTotal(i)=Join(loopstrTotal(i),vbcrlf)
end if
next
content=replace(content,match.value,Join(loopstrTotal,vbcrlf))
content=replace(content,"{playpage:"&str&"listlen}",i_2)
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function parseNews(vid,vauthot,vtitle,vcontent,vaddtime,vcolor,vhit)
dim labelRule,matchfield ,matches , fieldNameAndAttr , m , fieldName ,fieldAttr
labelRule="{news:([\s\S]+?)}"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each matchfield in matches
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "id"
content=replaceStr(content,matchfield.value,vid)
case "title"
dim m_title,m_titlelen
m_title=vtitle:m_titlelen=parseAttr(fieldAttr)("len")
if not isNul(m_titlelen) and len(m_title) > clng(m_titlelen) then m_title=left(m_title,clng(m_titlelen)-1)&".."
content=replaceStr(content,matchfield.value,m_title)
case "hit"
if isnul(vhit) then vhit=0
content=replaceStr(content,matchfield.value,"加载中")
case "colortitle"
dim m_colortitle,m_colortitlelen:m_colortitle=vtitle:m_colortitlelen=parseAttr(fieldAttr)("len")
if not isNul(m_colortitlelen) and len(m_colortitle) > clng(m_colortitlelen) then m_colortitle=left(m_colortitle,clng(m_colortitlelen)-1)&".."
if not(isnul(vcolor)) then m_colortitle=""&m_colortitle&""
content=replaceStr(content,matchfield.value,m_colortitle)
case "content"
dim m_content,m_contentlen:m_content=decodeHtml(vcontent)
m_contentlen=parseAttr(fieldAttr)("len")
if not isNul(m_contentlen) and len(m_content) > clng(m_contentlen) then m_content=left(m_content,clng(m_contentlen)-1)&".."
content=replaceStr(content,matchfield.value,m_content)
case "addtime"
dim timestyle,addtime : timestyle=parseAttr(fieldAttr)("style") :if isNul(timestyle) then timestyle="m-d"
addtime=vaddtime
dim monthDayTime : if month(addtime)<10 then monthDayTime="0"&month(addtime) else monthDayTime = month(addtime)
if day(addtime)<10 then monthDayTime=monthDayTime&"-0"&day(addtime) else monthDayTime=monthDayTime&"-"&day(addtime)
select case timestyle
case "yyyy-mm-dd"
content=replaceStr(content,matchfield.value,year(addtime)&"-"&monthDayTime)
case "yy-mm-dd"
content=replaceStr(content,matchfield.value,right(year(addtime),2)&"-"&monthDayTime)
case "yyyy-m-d"
content=replaceStr(content,matchfield.value,year(addtime)&"-"&month(addtime)&"-"&day(addtime))
case else
content=replaceStr(content,matchfield.value,monthDayTime)
end select
end select
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function newsPagelist(currentPage)
dim matchChannel,matches,sql,orderstr,matchesfield,loopstrChannel,rsObj,loopstrVlistNew,labelRulePagelist
dim attrChannel,vsize,vorder,loopstrChannelNew,matchfield,matchesPagelist,matchPagelist,lenPagelist,pageListType,strPagelist
dim i,labelRuleField,n : n=0
dim vnum , vstart ,m ,fieldName ,fieldAttr
dim attrDictionary , loopstrTotal ,fieldNameAndAttr
labelRulePagelist="\[newspagelist:pagenumber([\s\S]*?)\]"
labelRule="{maxcms:newspagelist([\s\S]*?)}([\s\S]*?){/maxcms:newspagelist}"
labelRuleField="\[newspagelist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each matchChannel in matches
attrChannel=matchChannel.SubMatches(0)
loopstrChannel=matchChannel.SubMatches(1)
set attrDictionary=parseAttr(attrChannel)
vsize=attrDictionary("size") : vorder=attrDictionary("order")
if isnul(vsize) then vsize=12
select case vorder
case "id" : orderstr=" order by m_id desc"
case "hit" : orderstr="order by m_hit desc"
case "title" : orderstr="order by m_title desc"
end select
set attrDictionary=nothing
sql="select m_id,m_title,m_addtime,m_content,m_hit,m_color from {pre}info where m_type='news' "&orderstr
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrChannel)
set rsObj=conn.db(sql,"records1")
if rsObj.eof then
loopstrTotal=newspageInfo(0)
else
rsObj.pagesize=vsize
if clng(currentPage)>clng(rsObj.pagecount) then currentPage=rsObj.pagecount
rsObj.absolutepage=currentPage
loopstrTotal=""
for i=0 to vsize-1
loopstrVlistNew=loopstrChannel
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "i"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,i+1)
case "id"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,rsobj(0))
case "hit"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,rsobj(4)+1)
case "title"
dim m_title,m_titlelen
m_title=rsObj(1):m_titlelen=parseAttr(fieldAttr)("len")
if not isNul(m_titlelen) and len(m_title) > clng(m_titlelen) then m_title=left(m_title,clng(m_titlelen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_title)
case "colortitle"
dim m_color,m_colortitle,m_colortitlelen
m_color=rsObj(5):m_colortitle=rsObj(1):m_colortitlelen=parseAttr(fieldAttr)("len")
if not isNul(m_colortitlelen) and len(m_colortitle) > clng(m_colortitlelen) then m_colortitle=left(m_colortitle,clng(m_colortitlelen)-1)&".."
if not(isnul(m_color)) then m_colortitle=""&m_colortitle&""
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_colortitle)
case "addtime"
dim timestyle,addtime : timestyle=parseAttr(fieldAttr)("style") : if isNul(timestyle) then timestyle="m-d"
addtime=rsObj(2)
dim monthDayTime : if month(addtime)<10 then monthDayTime="0"&month(addtime) else monthDayTime = month(addtime)
if day(addtime)<10 then monthDayTime=monthDayTime&"-0"&day(addtime) else monthDayTime=monthDayTime&"-"&day(addtime)
select case timestyle
case "yyyy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(addtime)&"-"&monthDayTime)
case "yy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,right(year(addtime),2)&"-"&monthDayTime)
case "yyyy-m-d"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(addtime)&"-"&month(addtime)&"-"&day(addtime))
case else
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,monthDayTime)
end select
case "content"
dim m_content,contentlen:m_content=filterStr(decodeHtml(rsObj(3)),"html"):contentlen=parseAttr(fieldAttr)("len")
if isNul(contentlen) then contentlen=200
if len(m_content) > clng(contentlen) then m_content=left(m_content,clng(contentlen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_content)
case "newslink"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,getNewsContentLink(rsObj(0),rsObj(2)))
end select
strDictionary.removeAll
next
loopstrTotal=loopstrTotal&loopstrVlistNew
rsObj.movenext
if rsObj.eof then exit for
next
end if
content=replace(content,matchChannel.value,loopstrTotal)
regExpObj.Pattern=labelRulePagelist
set matchesPagelist=regExpObj.Execute(content)
for each matchPagelist in matchesPagelist
if rsObj.pagecount=0 then
content=replace(content,matchPagelist.value,"")
else
lenPagelist=parseAttr(matchPagelist.SubMatches(0))("len")
if isNul(lenPagelist) then lenPagelist=10 else lenPagelist=clng(lenPagelist)
strPagelist=pageNumberLinkInfo(currentPage,lenPagelist,rsObj.pagecount,"newspagelist",rsObj.recordcount)
content=replace(content,matchPagelist.value,strPagelist)
end if
next
set matchesPagelist=nothing
set matchesfield=nothing
strDictionary.removeAll
next
set matches=nothing
End Function
Public Function parseNewsList
if not isExistStr(content,"{maxcms:newslist") then Exit Function
dim match,matches,matchfield,matchesfield,newsListArray
dim labelAttrVideolist,loopstrVideoList , loopstrVlistNew
dim i,labelRuleField,n : n=0
dim vnum , vstart ,m ,fieldName ,fieldAttr
dim attrDictionary , loopstrTotal ,fieldNameAndAttr
dim sql
labelRule="{maxcms:newslist([\s\S]*?)}([\s\S]*?){/maxcms:newslist}"
labelRuleField="\[newslist:([\s\S]+?)\]"
regExpObj.Pattern=labelRule
set matches=regExpObj.Execute(content)
for each match in matches
labelAttrVideolist=match.SubMatches(0)
loopstrVideoList=match.SubMatches(1)
set attrDictionary=parseAttr(labelAttrVideolist)
vnum=attrDictionary("num"): vstart=attrDictionary("start")
if isNul(vnum) then vnum=10 else vnum=clng(vnum)
if not isNul(vstart) then vstart=clng(vstart) else vstart=1
n=vstart-1 : vnum=vnum+vstart-1
sql="select top "&vnum+1&" m_id,m_author,m_title,m_content,m_addtime,m_color from {pre}info where m_type='news' order by m_id desc"
conn.fetchCount=vnum:newsListArray=conn.db(sql,"array"):conn.fetchCount=0
regExpObj.Pattern=labelRuleField
set matchesfield=regExpObj.Execute(loopstrVideoList)
loopstrTotal=""
if isArray(newsListArray) then vnum=ubound(newsListArray,2) else vnum=-1
for i=n to vnum
loopstrVlistNew=loopstrVideoList
for each matchfield in matchesfield
fieldNameAndAttr=regExpReplace(matchfield.SubMatches(0),"[\s]+",chr(32))
fieldNameAndAttr=trimOuter(fieldNameAndAttr)
m=instr(fieldNameAndAttr,chr(32))
if m > 0 then
fieldName=left(fieldNameAndAttr,m - 1)
fieldAttr = right(fieldNameAndAttr,len(fieldNameAndAttr) - m)
else
fieldName=fieldNameAndAttr
fieldAttr = ""
end if
select case fieldName
case "i"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,i+1)
case "id"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,newsListArray(0,i))
case "title"
dim m_title,m_titlelen
m_title=newsListArray(2,i):m_titlelen=parseAttr(fieldAttr)("len")
if not isNul(m_titlelen) and len(m_title)>clng(m_titlelen) then m_title=left(m_title,clng(m_titlelen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_title)
case "colortitle"
dim m_color,m_colortitle,m_colortitlelen
m_color=newsListArray(5,i):m_colortitle=newsListArray(2,i):m_colortitlelen=parseAttr(fieldAttr)("len")
if not isNul(m_colortitlelen) and len(m_colortitle) > clng(m_colortitlelen) then m_colortitle=left(m_colortitle,clng(m_colortitlelen)-1)&".."
if not(isnul(m_color)) then m_colortitle=""&m_colortitle&""
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_colortitle)
case "addtime"
dim timestyle,addtime : timestyle=parseAttr(fieldAttr)("style") : if isNul(timestyle) then timestyle="m-d"
addtime=newsListArray(4,i)
dim monthDayTime : if month(addtime)<10 then monthDayTime="0"&month(addtime) else monthDayTime = month(addtime)
if day(addtime)<10 then monthDayTime=monthDayTime&"-0"&day(addtime) else monthDayTime=monthDayTime&"-"&day(addtime)
select case timestyle
case "yyyy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(addtime)&"-"&monthDayTime)
case "yy-mm-dd"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,right(year(addtime),2)&"-"&monthDayTime)
case "yyyy-m-d"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,year(addtime)&"-"&month(addtime)&"-"&day(addtime))
case else
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,monthDayTime)
end select
case "content"
dim m_content,contentlen:m_content=decodeHtml(newsListArray(3,i)):contentlen=parseAttr(fieldAttr)("len")
if isNul(contentlen) then contentlen=200
if len(m_content) > clng(contentlen) then m_content=left(m_content,clng(contentlen)-1)&".."
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,m_content)
case "newslink"
loopstrVlistNew=replaceStr(loopstrVlistNew,matchfield.value,getNewsContentLink(newsListArray(0,i),newsListArray(4,i)))
end select
strDictionary.removeAll
next
loopstrTotal=loopstrTotal&loopstrVlistNew
next
set matchesfield=nothing
content=replaceStr(content,match.value,loopstrTotal)
strDictionary.removeAll
next
set matches=nothing
End Function
Private Sub parseSlide()
dim slideAtrrStr,slideStr,slideStr2,slidew,slideh
slideStr="{maxcms:slide"
if isExistStr(content,slideStr) then
slideStr2=getSubStrByFromAndEnd(content,slideStr,"}","")
slidew=parseAttr(slideStr2)("width"):slideh=parseAttr(slideStr2)("height")
if isNul(slidew) then slidew=400
if isNul(slideh) then slideh=280
content=replaceStr(content,slideStr&slideStr2&"}","")
end if
strDictionary.removeAll
End Sub
Public Function paresPreNextVideo(dataid,typeFlag,vtype)
dim nextid , lastid , nextname ,lastname,mystr,preNextLabel:preNextLabel="{playpage:prenext}"
if not isExistStr(content,preNextLabel) then Exit Function
dim rs :set rs=conn.db("select top 1 m_id as nextid ,m_name as nextname from m_data where m_type="&vtype&" and m_id<"&dataId&" order by m_id desc ","records1")
if rs.eof and rs.bof then nextid= 0 else nextid=rs("nextid"): nextname=rs("nextname")
set rs=conn.db("select top 1 m_id as lastid,m_name as lastname from m_data where m_type="&vtype&" and m_id>"&dataId&" order by m_id asc ","records1")
if rs.eof and rs.bof then lastid= 0 else lastid=rs("lastid") : lastname=rs("lastname")
rs.close
set rs=nothing
if typeFlag="parse_play_" then
if lastid = 0 then mystr = "上一篇:没有了 " else mystr = "上一篇:"&lastname&" "
if nextid = 0 then mystr = mystr&"下一篇:没有了" else mystr = mystr&"下一篇:"&nextname&""
else
if lastid = 0 then mystr = "上一篇:没有了 " else mystr = "上一篇:"&lastname&" "
if nextid = 0 then mystr = mystr&"下一篇:没有了" else mystr = mystr&"下一篇:"&nextname&""
end if
content=replaceStr(content,preNextLabel,mystr)
End Function
Public Function parsePlayPageSpecial()
content=replace(content,"{playpage:reporterr}","报 错")
content=replace(content,"{playpage:digg}","{playpage:diggnum}顶一下")
content=replace(content,"{playpage:tread}","{playpage:treadnum}踩一下")
content=replace(content,"{playpage:comment}","
评论加载中..
")
content=replace(content,"{playpage:hit}","加载中")
End Function
Public Function parseIf()
if not isExistStr(content,"{if:") then Exit Function
dim matchIf,matchesIf,strIf,strThen,strThen1,strElse1,labelRule2,labelRule3
dim ifFlag,elseIfArray,elseIfSubArray,elseIfArrayLen,resultStr,elseIfLen,strElseIf,strElseIfThen,elseIfFlag
labelRule="{if:([\s\S]+?)}([\s\S]*?){end\s+if}":labelRule2="{elseif":labelRule3="{else}":elseIfFlag=false
regExpObj.Pattern=labelRule
set matchesIf=regExpObj.Execute(content)
for each matchIf in matchesIf
strIf=matchIf.SubMatches(0):strThen=matchIf.SubMatches(1)
if instr(strThen,labelRule2)>0 then
elseIfArray=split(strThen,labelRule2):elseIfArrayLen=ubound(elseIfArray):elseIfSubArray=split(elseIfArray(elseIfArrayLen),labelRule3)
resultStr=elseIfSubArray(1)
Execute("if "&strIf&" then resultStr=elseIfArray(0)")
for elseIfLen=1 to elseIfArrayLen-1
strElseIf=getSubStrByFromAndEnd(elseIfArray(elseIfLen),":","}","")
strElseIfThen=getSubStrByFromAndEnd(elseIfArray(elseIfLen),"}","","start")
Execute("if "&strElseIf&" then resultStr=strElseIfThen")
Execute("if "&strElseIf&" then elseIfFlag=true else elseIfFlag=false")
if elseIfFlag then exit for
next
Execute("if "&getSubStrByFromAndEnd(elseIfSubArray(0),":","}","")&" then resultStr=getSubStrByFromAndEnd(elseIfSubArray(0),""}"","""",""start""):elseIfFlag=true")
content=replace(content,matchIf.value,resultStr)
else
if instr(strThen,"{else}")>0 then
strThen1=split(strThen,labelRule3)(0)
strElse1=split(strThen,labelRule3)(1)
Execute("if "&strIf&" then ifFlag=true else ifFlag=false")
if ifFlag then content=replace(content,matchIf.value,strThen1) else content=replace(content,matchIf.value,strElse1)
else
Execute("if "&strIf&" then ifFlag=true else ifFlag=false")
if ifFlag then content=replace(content,matchIf.value,strThen) else content=replace(content,matchIf.value,"")
end if
end if
elseIfFlag=false
next
set matchesIf=nothing
End Function
End Class
Class MainClass_DataList
Public primaryField,tableStr
Public orderStr,whereStr,dataSortType,fieldsStr,dataPageSize,dataCurrentPage
Public recordsCount,pagesCount
private tempTableCount,sqlstr,topCount,whereStr2,whereStr3
private m,n
Public Sub Class_Initialize
dataSortType="desc"
End Sub
Public Sub Class_Terminate
End Sub
Public Function getDataList()
dim order
if isNul(dataPageSize) then dataPageSize=100 else dataPageSize=clng(dataPageSize)
if not isNul(whereStr) then whereStr= " where "&whereStr else whereStr=""
if isNul(tableStr) then die err_table
if isNul(fieldsStr) then fieldsStr=" * " else fieldsStr=" "&fieldsStr&" "
if not isNul(orderStr) then order=" order by "&orderStr&" "&dataSortType else order=" "
sqlstr="select top "&dataPageSize&fieldsStr&" from "&tableStr&" "&whereStr&order
getDataList=conn.db(sqlstr,"array")
End Function
Public Function getPageList()
dim order
if isNul(dataPageSize) then dataPageSize=30 else dataPageSize=clng(dataPageSize)
if not isNul(whereStr) then whereStr2=" where "&whereStr : whereStr3=" and "&whereStr else whereStr2="":whereStr3=""
'die "select count(*) from "&tableStr&whereStr2
recordsCount=conn.db("select count(*) from "&tableStr&whereStr2,"array")(0,0)
m=recordsCount mod dataPageSize
n=int(recordsCount / dataPageSize)
if m=0 then pagesCount=n else pagesCount=n + 1
if isNul(primaryField) then die err_primarykey
if isNul(tableStr) then die err_table
if isNul(orderStr) then orderStr=primaryField
if isNul(fieldsStr) then fieldsStr=" * " else fieldsStr=" "&fieldsStr&" "
if dataCurrentPage > pagesCount then dataCurrentPage=pagesCount
if isNul(dataCurrentPage) then
dataCurrentPage=1
else
if dataCurrentPage <= 0 then dataCurrentPage=1 else dataCurrentPage=clng(dataCurrentPage)
end if
order=" "&orderStr&" "&dataSortType
if dataSortType="desc" then
if dataCurrentPage=1 then
sqlstr="select top "&dataPageSize&fieldsStr&" from "&tableStr&" "&whereStr2&" order by "&order
else
sqlstr="select top "&dataPageSize&fieldsStr&" from "&tableStr&" where "&primaryField&"<(select min("&primaryField&") from (select top "&(dataCurrentPage - 1) * dataPageSize&" "&primaryField&" from "&tableStr &" "&whereStr2& " order by "&order&") as temptable) "& whereStr3& " order by "&order
end if
else dataSortType="asc"
if dataCurrentPage=1 then
sqlstr="select top "&dataPageSize&fieldsStr&" from "&tableStr&" "&whereStr2&" order by "&order
else
sqlstr="select top "&dataPageSize&fieldsStr&" from "&tableStr&" where "&primaryField&">(select max("&primaryField&") from (select top "&(dataCurrentPage - 1) * dataPageSize &" "&primaryField&" from "&tableStr &" "& whereStr& " order by "&order&") as temptable) "& whereStr3& " order by "&order
end if
end if
getPageList=conn.db(sqlstr,"array")
End Function
End Class
Class MainClass_Xml
Public xmlDocument,xmlPath,xmlDomObj,xmlstr
Private xmlDomVer,xmlFileSavePath
Public Sub Class_Initialize()
xmlDomVer=getXmlDomVer()
createXmlDomObj
End Sub
Public Sub Class_Terminate()
If IsObject(xmlDomObj) Then Set xmlDomObj=Nothing
End Sub
Public Function getXmlDomVer()
dim i,xmldomVersions,xmlDomVersion
getXmlDomVer=false
xmldomVersions=Array("Microsoft.2MLDOM","MSXML2.DOMDocument","MSXML2.DOMDocument.3.0","MSXML2.DOMDocument.4.0","MSXML2.DOMDocument.5.0")
for i=0 to ubound(xmldomVersions)
xmlDomVersion=xmldomVersions(i)
if isInstallObj(xmlDomVersion) then getXmlDomVer=xmlDomVersion : Exit Function
next
End Function
Private Sub createXmlDomObj
set xmlDomObj=server.CreateObject(xmlDomVer)
xmlDomObj.validateonparse=true
xmlDomObj.async=false
End Sub
Public Function load(Byval xml,Byval xmlType)
dim xmlUrl,xmlfilePath
select case xmlType
case "xmlfile"
xmlfilePath=server.mappath(xml)
xmlDomObj.load(xmlfilePath)
case "xmldocument"
xmlUrl=xml
xmlstr=getRemoteContent(xmlUrl,"text")
If left(xmlstr, 5) <> " "
<%
dim siteName,channelDirName1,contentDirName1,playDirName1,channelPageName2,contentPageName2,playPageName2,channelDirName3,contentDirName3,playDirName3,channelPageName3,contentPageName3,playPageName3,topicDirName,sitePic,siteAd,siteDes,copyRight,siteUrl,sitePath,databaseType,databaseServer,databaseName,databaseUser,databasePwd,accessFilePath,templateFileFolder,siteKeyWords,siteNotice,defaultTemplate,siteVisiteJs,siteMode,makeTimeSpan,cacheStart,cacheTime,cacheFlag,RunMode,fileSuffix,makeMode,waterMark,waterMarkFont,waterMarkLocation,gatherSet,isAlertWin,alertWinW,alertWinH,ismakeplay,commentStart,gbookStart,dirtyWords,topicDirName4,channelDirName4,contentDirName4,playDirName4,channelpagename4,contentpagename4,playPageName4,newsDirName,newsPageListName,md5Content,gbookTime,gbookUser,gbookPwd,commentTime,isAutoCheck,allowAutoGather
siteName="老鼠视频" '站点名称
siteUrl="www.cnrat.com" '站点网址
sitePath="" '安装目录(根目录为空；二级目录填写为:二级目录名/)
databaseType=0 '数据库类型（0为access；1为sqlserver）
databaseServer="(local)" 'sqlserver数据库地址
databaseName="maxcms" 'sqlserver数据库名称
databaseUser="sa" 'sqlserver数据库账号
databasepwd="sa" 'sqlserver数据库密码
accessFilePath="/inc/datas.asp" 'access数据库文件路径(站点在根目录为:/inc/datas.asp；二级目录为：/二级目录名/inc/datas.asp）
templateFileFolder="html"
defaultTemplate="xuelei2.6"
gbookStart=1
commentStart=1
cacheStart=1
siteMode=""
cacheTime=10
cacheFlag="C2009121182040_"
runMode="static"
fileSuffix=".html"
makeMode="dir2"
makeTimeSpan=3
waterMark=0
waterMarkFont="maxcms"
waterMarkLocation="rightbottom"
channelDirName1="class"
contentDirName1="content"
playDirName1="video"
channelPageName2="index"
contentPageName2="index"
playPageName2="player"
channelDirName3="list"
contentDirName3="view"
playDirName3="player"
channelPageName3=""
contentPageName3=""
playPageName3=""
topicDirName="zt"
sitePic="uploadimg"
siteAd="ads"
siteVisiteJs=""
siteKeyWords="美女 性感 写真 热舞 韩国 模特 车展 剧情 现场 女优 诱惑 恐怖 LIVE 科幻 翻唱 自拍 热舞 时尚 时装 写真 赛车 高清 内衣 表演 JAZZ MV 女郎 大赛 上海 康熙来了 车模"
siteNotice="欢迎光临，测试公告！， 测试公告！
欢迎光临，测试公告！欢迎光临，测试公告！欢迎光临，！fdfdfdf"
siteDes="更新最快的综合视频门户,美女 性感 写真 热舞 韩国 模特 车展 剧情 现场 恐怖 科幻 翻唱 自拍 热舞 时尚 时装 赛车 高清 内衣 表演 女郎 大赛 康熙来了 车模"
gatherSet=0
isAlertWin=0
alertWinW=720
alertWinH=530
ismakeplay=1
isAutoCheck=0
commentTime=10
gbookTime=30
gbookUser="admin"
gbookPwd="admin123"
md5Content="0"
newsPageListName="index"
newsDirName="news"
channelpagename4=""
contentpagename4=""
playPageName4=""
topicDirName4="zt"
channelDirName4="category"
contentDirName4="movie"
playDirName4="player"
dirtyWords="http://www.baidu.com"
allowAutoGather=0
copyRight="ICP证xxx号 | 管理员信箱：xxx#xxx.com | 版本：马克斯电影程序(MaxCMS) V2.8 | 马克斯官方论坛"
%>
<%
'******************************************************************************************
' Software name: Max(马克斯) Content Management System
' Version:2.8
' Web: http://maxcms.bokecc.com
' Author: 石头(maxcms2008@qq.com),yuet,长明,酒瓶
' Copyright (C) 2005-2009 北京梦之窗数码科技有限公司 版权所有
' 法律申明：MaxCMS程序所有代码100%原创、未引入任何网上代码,对一切抄袭行为、坚决严肃追究法律责任
'******************************************************************************************
Sub alertMsg(str,url)
dim urlstr
if url<>"" then urlstr="location.href='"&url&"';"
if not isNul(str) then str ="alert('"&str&"');"
echo("")
End Sub
Sub echoMsgAndGo(str,timenum)
echo str&",稍后将自动返回 进入网站首页"&" Powered By "&siteName
End Sub
Sub selectMsg(str,url1,url2)
echo("")
End Sub
Sub last
die ""
End Sub
Sub echo(str)
response.write(str)
response.Flush()
End Sub
Function rCookie(cookieName)
rCookie=request.cookies(cookieName)
End Function
Sub wCookie(cookieName,cookieValue)
response.cookies(cookieName)=cookieValue
End Sub
Sub wCookieInTime(cookieName,cookieValue,dateType,dateNum)
Response.Cookies(cookieName).Expires=DateAdd(dateType,dateNum,now())
response.cookies(cookieName)=cookieValue
End Sub
Function isNul(str)
if isnull(str) or str="" then isNul=true else isNul=false
End Function
Function isNum(str)
if not isNul(str) then isNum=isnumeric(str) else isNum=false
End Function
Function isUrl(str)
if not isNul(str) then
if left(str,7)="http://" then isUrl=true else isUrl=false
else
isUrl=false
end if
End Function
Function getFileFormat(str)
dim ext:str=trim(""&str):ext=""
if str<>"" then
if instr(" "&str,"?")>0 then:str=mid(str,1,instr(str,"?")-1):end if
if instrRev(str,".")>0 then:ext=mid(str,instrRev(str,".")):end if
end if
getFileFormat=ext
End Function
Sub die(str)
if not isNul(str) then
echo str
end if
response.End()
End Sub
Sub echoErr(byval str,byval id, byval des)
dim errstr,cssstr
cssstr=""
errstr=cssstr&"
提示：***【"&str&"】***
错误号："&id&" 错误描述："&des&"
Powered By "&siteName&"
"
cssstr=""
die(errstr)
End Sub
Function getForm(element,ftype)
Select case ftype
case "get"
getForm=trim(request.QueryString(element))
case "post"
getForm=trim(request.Form(element))
case "both"
if isNul(request.QueryString(element)) then getForm=trim(request.Form(element)) else getForm=trim(request.QueryString(element))
End Select
End Function
Function isInstallObj(objname)
dim isInstall,obj
On Error Resume Next
set obj=server.CreateObject(objname)
if Err then
isInstallObj=false : err.clear
else
isInstallObj=true:set obj=nothing
end if
End Function
Function loadFile(ByVal filePath)
dim errid,errdes
On Error Resume Next
With objStream
.Type=2
.Mode=3
.Open
.Charset="gbk"
.LoadFromFile Server.MapPath(filePath)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_loadfile,errid,errdes
.Position=0
loadFile=.ReadText
.Close
End With
End Function
Function loadFileOnCache(Byval fileFlag,Byval filePath)
dim cacheName
cacheName=fileFlag&filePath
if cacheStart=1 then
if (cacheObj.chkCache(cacheName)) then loadFileOnCache=cacheObj.getCache(cacheName) else loadFileOnCache=loadFile(filePath):cacheObj.setCache cacheName,loadFileOnCache
else
loadFileOnCache=loadFile(filePath)
end if
End Function
Sub setStartTime()
starttime=timer()
End Sub
Sub echoRunTime()
endtime=timer()
echo pageRunStr(0)&FormatNumber((endtime-starttime),4,-1)&pageRunStr(1)&conn.queryCount&pageRunStr(2)
End Sub
Function getRunTime()
endtime=timer()
getRunTime=pageRunStr(0)&FormatNumber((endtime-starttime),4,-1)&pageRunStr(1)&conn.queryCount&pageRunStr(2)
End Function
Function getKeywordsList(key,span)
dim keyWordsArray,i,keyWordsStr,keystr
keystr=replaceStr(key,"，",",")
if instr(keystr,",")>0 then keyWordsArray=split(keystr,",") else keyWordsArray=split(keystr," ")
for i=0 to ubound(keyWordsArray)
keyWordsStr=keyWordsStr&""&keyWordsArray(i)&""&span
next
getKeywordsList=keyWordsStr
End Function
Function getDataCount(countType)
dim whereStr
whereStr=" where year(m_addtime)="&Year(date)&" and month(m_addtime)="&month(date)&" and day(m_addtime)="&day(date)
select case countType
case "all"
getDataCount=conn.db("select count(*) from {pre}data","execute")(0)
case "day"
getDataCount=conn.db("select count(*) from {pre}data "&whereStr,"execute")(0)
end select
End Function
Function replaceStr(Byval str,Byval finStr,Byval repStr)
on error resume next
if isNull(repStr) then repStr=""
replaceStr=replace(str,finStr,repStr)
if err then replaceStr="" : err.clear
End Function
Function getArrayElementID(Byval parray,Byval itemid,Byval compareValue)
dim i
for i=0 to ubound(parray,2)
if trim(parray(itemid,i))=trim(compareValue) then
getArrayElementID=i
Exit Function
end if
next
End Function
Function trimOuter(Byval str)
dim vstr : vstr=str
if left(vstr,1)=chr(32) then vstr=right(vstr,len(vstr)-1)
if right(vstr,1)=chr(32) then vstr=left(vstr,len(vstr)-1)
trimOuter=vstr
End Function
Function trimOuterStr(Byval str,Byval flag)
dim vstr,m : vstr=str : m=len(flag)
if left(vstr,m)=flag then vstr=right(vstr,len(vstr)-m)
if right(vstr,m)=flag then vstr=left(vstr,len(vstr)-m)
trimOuterStr=vstr
End Function
Function getPageSize(Byval str,Byval ptype)
dim regObj,matchChannel,matchesChannel,sizeValue
set regObj=New RegExp
regObj.Pattern="\{maxcms:"&ptype&"list[\s\S]*size=([\d]+)[\s\S]*\}"
set matchesChannel=regObj.Execute(str)
for each matchChannel in matchesChannel
sizeValue=matchChannel.SubMatches(0) : if isNul(sizeValue) then sizeValue=10
set regObj=nothing
set matchesChannel=nothing
getPageSize=sizeValue
Exit Function
next
End Function
Function getPageSizeOnCache(Byval templatePath,Byval Flag,Byval Flag2)
dim cacheName,pSize
cacheName=Flag&"_pagesize_"&Flag2
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then pSize=cacheObj.getCache(cacheName) else pSize=getPageSize(loadFile(templatePath),Flag) : cacheObj.setCache cacheName,pSize
else
pSize=getPageSize(loadFile(templatePath),Flag)
end if
getPageSizeOnCache=pSize
End Function
Function filterStr(Byval str,Byval filtertype)
if isNul(str) then filterStr="" : Exit Function
dim regObj, outstr,rulestr : set regObj=New Regexp
regObj.IgnoreCase=true : regObj.Global=true
Select case filtertype
case "html"
rulestr="(<[a-zA-Z].*?>)|(<[\/][a-zA-Z].*?>)"
case "jsiframe"
rulestr="(<(script|iframe).*?>)|(<[\/](script|iframe).*?>)"
end Select
regObj.Pattern=rulestr
outstr=regObj.Replace(str, "")
set regObj=Nothing : filterStr=outstr
End Function
Function getAgent()
getAgent=request.ServerVariables("HTTP_USER_AGENT")
End Function
Function getRefer()
getRefer=request.ServerVariables("HTTP_REFERER")
End Function
Function getServername()
getServername=request.ServerVariables("server_name")
End Function
Function isOutSubmit()
dim server1, server2
server1=getRefer
server2=getServername
if Mid(server1, 8, len(server2)) <> server2 then
isOutSubmit=true
else
isOutSubmit=false
end if
End Function
Function getIp()
dim forwardFor
forwardFor=request.servervariables("Http_X_Forwarded_For")
if forwardFor="" then
getIp=request.servervariables("Remote_Addr")
else
getIp=forwardFor
end if
getIp=replace(getIp, chr(39), "")
End Function
Function createTextFile(Byval content,Byval fileDir,Byval code)
dim fileobj,fileCode : fileDir=replace(fileDir, "\", "/")
if isNul(code) then fileCode="gbk" else fileCode=code
call createfolder(fileDir,"filedir")
on error resume next:err.clear
set fileobj=objFso.CreateTextFile(server.mappath(fileDir),True)
fileobj.Write(content)
set fileobj=nothing
if Err or not isNul(code) then
err.clear
With objStream
.Charset=fileCode:.Type=2:.Mode=3:.Open:.Position=0
.WriteText content:.SaveToFile Server.MapPath(fileDir), 2
.Close
End With
end if
if Err Then createTextFile=false : errid=err.number:errdes=err.description:Err.Clear : echoErr err_writefile,errid,errdes else createTextFile=true
End Function
Function createStreamFile(Byval stream,Byval fileDir)
dim errid,errdes
fileDir=replace(fileDir, "\", "/")
call createfolder(fileDir,"filedir")
on error resume next
With objStream
.Type =1
.Mode=3
.Open
.write stream
.SaveToFile server.mappath(fileDir),2
.close
End With
if Err Then error.clear:createStreamFile=false else createStreamFile=true
End Function
Function createFolder(Byval dir,Byval dirType)
dim subPathArray,lenSubPathArray, pathDeep, i
on error resume next
dir=replace(dir, "\", "/")
dir=replace(server.mappath(dir), server.mappath("/"), "")
subPathArray=split(dir, "\")
pathDeep=pathDeep&server.mappath("/")
select case dirType
case "filedir"
lenSubPathArray=ubound(subPathArray) - 1
case "folderdir"
lenSubPathArray=ubound(subPathArray)
end select
for i=1 to lenSubPathArray
pathDeep=pathDeep&"\"&subPathArray(i)
if not objFso.FolderExists(pathDeep) then objFso.CreateFolder pathDeep
next
if Err Then createFolder=false : errid=err.number:errdes=err.description:Err.Clear : echoErr err_createFolder,errid,errdes else createFolder=true
End Function
Function isExistFile(Byval fileDir)
on error resume next
If (objFso.FileExists(server.MapPath(fileDir))) Then isExistFile=True Else isExistFile=False
if err then err.clear:isExistFile=False
End Function
Function isExistFolder(Byval folderDir)
on error resume next
If objFso.FolderExists(server.MapPath(folderDir)) Then isExistFolder=True Else isExistFolder=False
if err then err.clear:isExistFolder=False
End Function
Function delFolder(Byval folderDir)
on error resume next
If isExistFolder(folderDir)=True Then
objFso.DeleteFolder(server.mappath(folderDir))
if Err Then delFolder=false : errid=err.number : errdes=err.description:Err.Clear : echoErr err_delFolder,errid,errdes else delFolder=true
else
delFolder=false : die(err_notExistFolder)
end if
End Function
Function delFile(Byval fileDir)
on error resume next
If isExistFile(fileDir)=True Then objFso.DeleteFile(server.mappath(fileDir))
if Err Then delFile=false : errid=err.number : errdes=err.description:Err.Clear : echoErr err_delFile,errid,errdes else delFile=true
End Function
Function initializeAllObjects()
dim errid,errdes
on error resume next
if not isobject(objFso) then set objFso=server.createobject(FSO_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_fsoobj,errid,errdes
if not isobject(objStream) then Set objStream=Server.CreateObject(STREAM_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_stmobj,errid,errdes
End Function
Function terminateAllObjects()
on error resume next
if conn.isConnect then conn.close
if isobject(conn) then : set conn=nothing
if isobject(objFso) then set objFso=nothing
if isobject(objStream) then set objStream=nothing
if isobject(cacheObj) then set cacheObj=nothing
if isobject(mainClassObj) then set mainClassObj=nothing
if isObject(gXmlHttpObj) then SET gXmlHttpObj=Nothing
End Function
Function moveFolder(oldFolder,newFolder)
dim voldFolder,vnewFolder
voldFolder=oldFolder
vnewFolder=newFolder
on error resume next
if voldFolder <> vnewFolder then
voldFolder=server.mappath(oldFolder)
vnewFolder=server.mappath(newFolder)
if not objFso.FolderExists(vnewFolder) then createFolder newFolder,"folderdir"
if objFso.FolderExists(voldFolder) then objFso.CopyFolder voldFolder,vnewFolder : objFso.DeleteFolder(voldFolder)
if Err Then moveFolder=false : errid=err.number : errdes=err.description:Err.Clear : echoErr err_moveFolder,errid,errdes else moveFolder=true
end if
End Function
Function moveFile(ByVal src,ByVal target,Byval operType)
dim srcPath,targetPath
srcPath=Server.MapPath(src)
targetPath=Server.MapPath(target)
if isExistFile(src) then
objFso.Copyfile srcPath,targetPath
if operType="del" then delFile src
moveFile=true
else
moveFile=false
end if
End Function
Function getFolderList(Byval cDir)
dim filePath,objFolder,objSubFolder,objSubFolders,i
i=0
redim folderList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objSubFolders=objFolder.Subfolders
for each objSubFolder in objSubFolders
ReDim Preserve folderList(i)
With objSubFolder
folderList(i)=.name&",文件夹,"&.size/1000&"k,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFolder=nothing
set objSubFolders=nothing
getFolderList=folderList
End Function
Function getFileList(Byval cDir)
dim filePath,objFolder,objFile,objFiles,i
i=0
redim fileList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objFiles=objFolder.Files
for each objFile in objFiles
ReDim Preserve fileList(i)
With objFile
fileList(i)=.name&","&Mid(.name, InStrRev(.name, ".") + 1)&","&.size/1000&"k,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFiles=nothing
set objFolder=nothing
getFileList=fileList
End Function
Function getXmlHttpVer()
dim i,xmlHttpVersions,xmlHttpVersion
getXmlHttpVer=false
xmlHttpVersions=Array("Microsoft.XMLHTTP", "MSXML2.XMLHTTP", "MSXML2.XMLHTTP.3.0","MSXML2.XMLHTTP.4.0","MSXML2.XMLHTTP.5.0")
for i=0 to ubound(xmlHttpVersions)
xmlHttpVersion=xmlHttpVersions(i)
if isInstallObj(xmlHttpVersion) then getXmlHttpVer=xmlHttpVersion : Exit Function
next
End Function
Function tryXmlHttp()
dim i,xmlHttpVersions
On Error Resume Next
xmlHttpVersions=Array("Microsoft.XMLHTTP", "MSXML2.XMLHTTP", "MSXML2.XMLHTTP.3.0","MSXML2.XMLHTTP.4.0","MSXML2.XMLHTTP.5.0")
for i=0 to ubound(xmlHttpVersions)
SET tryXmlHttp=Server.CreateObject(xmlHttpVersions(i))
if err.number=0 then:Exit Function:else:err.clear:end if
next
End Function
dim gXmlHttpObj
Function getRemoteContent(Byval url,Byval returnType)
if not isObject(gXmlHttpObj) then:set gXmlHttpObj=tryXmlHttp():end if
gXmlHttpObj.open "GET",url,False
gXmlHttpObj.send()
select case returnType
case "text"
getRemoteContent=gXmlHttpObj.responseText
case "body"
getRemoteContent=gXmlHttpObj.responseBody
end select
End Function
Function bytesToStr(Byval responseBody,Byval strCharSet)
with objStream
.Type=1
.Mode =3
.Open
.Write responseBody
.Position=0
.Type=2
.Charset=strCharSet
bytesToStr=objstream.ReadText
objstream.Close
End With
End Function
Function computeStrLen(Byval str)
dim strlen,charCount,i
str=trim(str)
charCount=len(str)
strlen=0
for i=1 to charCount
if asc(mid(str,i,1)) < 0 or asc(mid(str,i,1)) >255 then
strlen=strlen + 2
else
strlen=strlen + 1
end if
next
computeStrLen=strlen
End Function
Function getStrByLen(Byval str, Byval strlen)
dim vStrlen,charCount,i
str=trim(str)
if isNul(str) then Exit Function
charCount=len(str)
vStrlen=0
for i=1 to charCount
if asc(mid(str,i,1)) < 0 or asc(mid(str,i,1)) >255 then
vStrlen=vStrlen + 2
else
vStrlen=vStrlen + 1
end if
if vStrlen >= strlen then getStrByLen=left(str,i) : Exit Function
next
getStrByLen=left(str,charCount)
End Function
Function encodeHtml(Byval str)
IF len(str)=0 OR Trim(str)="" then exit function
str=replace(str,"<","<")
str=replace(str,">",">")
str=replace(str,CHR(34),""")
str=replace(str,CHR(39),"'")
encodeHtml=str
End Function
Function decodeHtml(Byval str)
IF len(str)=0 OR Trim(str)="" or isNull(str) then exit function
str=replace(str,"<","<")
str=replace(str,">",">")
str=replace(str,""",CHR(34))
str=replace(str,"'",CHR(39))
decodeHtml=str
End Function
Function codeTextarea(Byval str,Byval enType)
select case enType
case "en"
codeTextarea=replace(replace(str,chr(10),""),chr(13)," ")
case "de"
codeTextarea=replace(str," ",chr(13)&chr(10))
end select
End Function
Function timeToStr(Byval t)
t=Replace(Replace(Replace(Replace(t,"-",""),":","")," ",""),"/","") : timeToStr=t
End Function
Function makePageNumber(Byval currentPage,Byval pageListLen,Byval totalPages,Byval linkType)
currentPage=clng(currentPage)
dim beforePages,pagenumber,page
dim beginPage,endPage,strPageNumber
if pageListLen mod 2=0 then beforePages=pagelistLen / 2 else beforePages=clng(pagelistLen / 2) - 1
if currentPage < 1 then currentPage=1 else if currentPage > totalPages then currentPage=totalPages
if pageListLen > totalPages then pageListLen=totalPages
if currentPage - beforePages < 1 then
beginPage=1 : endPage=pageListLen
elseif currentPage - beforePages + pageListLen > totalPages then
beginPage=totalPages - pageListLen + 1 : endPage=totalPages
else
beginPage=currentPage - beforePages : endPage=currentPage - beforePages + pageListLen - 1
end if
for pagenumber=beginPage to endPage
if pagenumber=1 then page="" else page=pagenumber
if clng(pagenumber)=clng(currentPage) then
if linkType="search" or linkType="channel" or linkType="newspagelist" or linkType="topicpage" then
strPageNumber=strPageNumber&""&pagenumber&""
else
strPageNumber=strPageNumber&""&pagenumber&""
end if
else
select case linkType
case "channel"
strPageNumber=strPageNumber&""&pagenumber&""
case "search"
strPageNumber=strPageNumber&""&pagenumber&""
case "videolist"
strPageNumber=strPageNumber&""&pagenumber&""
case "adslist","selflabellist","templist"
strPageNumber=strPageNumber&""&pagenumber&""
case "newslist"
strPageNumber=strPageNumber&""&pagenumber&""
case "topicpage"
strPageNumber=strPageNumber&""&pagenumber&""
case "newspagelist"
strPageNumber=strPageNumber&""&pagenumber&""
end select
end if
next
makePageNumber=strPageNumber
End Function
Function pageNumberLinkInfo(Byval currentPage,Byval pageListLen,Byval totalPages,Byval linkType,Byval totalRecords)
dim pageNumber,pagesStr,i,pageNumberInfo,firstPageLink,lastPagelink,nextPagelink,finalPageLink
pageNumber=makePageNumber(currentPage,pageListLen,totalPages,linkType)
select case linkType
case "search"
if currentPage=1 then
firstPageLink="首页" : lastPagelink="上一页"
else
firstPageLink="首页" : lastPagelink="上一页"
end if
if currentPage=totalPages then
nextPagelink="下一页" : finalPageLink="尾页"
else
nextPagelink="下一页" : finalPageLink="尾页"
end if
pagesStr=""
pageNumberInfo="共"&totalRecords&"条数据 页次:"¤tPage&"/"&totalPages&"页"&firstPageLink&lastPagelink&pageNumber&""&nextPagelink&""&finalPagelink&pagesStr
case "channel"
if currentPage=1 then
getChannelPagesLink currentTypeId,currentPage-1
firstPageLink="首页" : lastPagelink="上一页"
else
firstPageLink="首页" : lastPagelink="上一页"
end if
if currentPage=totalPages then
nextPagelink="下一页" : finalPageLink="尾页"
else
nextPagelink="下一页" : finalPageLink="尾页"
end if
pagesStr=""
pageNumberInfo="共"&totalRecords&"条数据 页次:"¤tPage&"/"&totalPages&"页"&firstPageLink&lastPagelink&pageNumber&""&nextPagelink&""&finalPagelink&pagesStr
case "topicpage"
if currentPage=1 then
getTopicPageLink currrent_topic_id,currentPage-1
firstPageLink="首页" : lastPagelink="上一页"
else
firstPageLink="首页" : lastPagelink="上一页"
end if
if currentPage=totalPages then
nextPagelink="下一页" : finalPageLink="尾页"
else
nextPagelink="下一页" : finalPageLink="尾页"
end if
pagesStr=""
pageNumberInfo="共"&totalRecords&"条数据 页次:"¤tPage&"/"&totalPages&"页"&firstPageLink&lastPagelink&pageNumber&""&nextPagelink&""&finalPagelink&pagesStr
case "newspagelist"
if currentPage=1 then
getNewsChannelLink currentPage-1
firstPageLink="首页" : lastPagelink="上一页"
else
firstPageLink="首页" : lastPagelink="上一页"
end if
if clng(currentPage)=clng(totalPages) then
nextPagelink="下一页" : finalPageLink="尾页"
else
nextPagelink="下一页" : finalPageLink="尾页"
end if
pagesStr=""
pageNumberInfo="共"&totalRecords&"条数据 页次:"¤tPage&"/"&totalPages&"页"&firstPageLink&lastPagelink&pageNumber&""&nextPagelink&""&finalPagelink&pagesStr
end select
pageNumberLinkInfo=pageNumberInfo
End Function
Function getTopicPageLink(Byval topicId,Byval page)
dim linkStr,topicPath,tempStr,topicname
if runMode="dynamic" then
if clng(page)=1 then tempStr="" else tempStr="-"&page
linkStr="/"&sitePath&topicDirName&"/?"&topicId&tempStr&fileSuffix
pageUrlStyle=1
elseif runMode="static" then
topicname=conn.db("select m_enname from {pre}topic where m_id="&topicId,"array")(0,0)
if clng(page)=1 then tempStr="" else tempStr="-"&page
linkStr="/"&sitePath&topicDirName&"/"&topicname&tempStr&fileSuffix
pageUrlStyle=6
elseif runMode="forgedStatic" then
if clng(page)=1 then tempStr="" else tempStr="-"&page
linkStr="/"&sitePath&topicDirName4&"/"&topicId&tempStr&fileSuffix
pageUrlStyle=5
end if
getTopicPageLink=linkStr
End Function
Function getChannelPagesLink(Byval typeId,Byval page)
dim linkStr,typePath,tempStr
if runMode="dynamic" then
if clng(page)=1 then tempStr="" else tempStr="-"&page
linkStr="/"&sitePath&channelDirName1&"/?"&typeId&tempStr&fileSuffix
pageUrlStyle=1
elseif runMode="static" and makeMode="dir1" then
pageUrlStyle=2
typePath=getTypePathOnCache(typeId)
if clng(page)=1 then page=""
linkStr="/"&sitePath&typePath&channelPageName2&page&fileSuffix
elseif runMode="static" and makeMode="dir2" then
pageUrlStyle=3
if clng(page)=1 then tempStr="" else tempStr="_"&page
linkStr="/"&sitePath&channelDirName3&"/"&channelPageName3&typeId&tempStr&fileSuffix
elseif runMode="forgedStatic" then
pageUrlStyle=5
if clng(page)=1 then tempStr="" else tempStr="-"&page
linkStr="/"&sitePath&channelDirName4&"/"&channelPageName4&typeId&tempStr&fileSuffix
end if
getChannelPagesLink=linkStr
End Function
Function getTypeLink(Byval typeId)
dim linkStr,typePath,fileName
if runMode="dynamic" then
linkStr="/"&sitePath&channelDirName1&"/?"&typeId&fileSuffix
elseif runMode="static" and makeMode="dir1" then
fileName=channelPageName2&fileSuffix
typePath=getTypePathOnCache(typeId)
linkStr="/"&sitePath&typePath
elseif runMode="static" and makeMode="dir2" then
linkStr="/"&sitePath&channelDirName3&"/"&channelPageName3&typeId&fileSuffix
elseif runMode="forgedStatic" then
linkStr="/"&sitePath&channelDirName4&"/"&channelPageName4&typeId&fileSuffix
end if
getTypeLink=linkStr
End Function
Function getNewsContentLink(Byval newsId,Byval newsDate)
dim linkStr
if runMode="dynamic" then
linkStr="/"&sitePath&newsDirName&"/?"&newsId&fileSuffix
elseif runMode="static" then
linkStr="/"&sitePath&newsDirName&"/"&getNewsFolder(newsDate)&"/"&newsId&fileSuffix
elseif runMode="forgedStatic" then
linkStr="/"&sitePath&newsDirName&"/"&newsId&fileSuffix
end if
getNewsContentLink=linkStr
End Function
Function getNewsChannelLink(Byval page)
dim linkstr
if runMode="dynamic" then
if page=1 then
linkStr="/"&sitePath&newsDirName&"/?"&newsPageListName&fileSuffix
else
linkStr="/"&sitePath&newsDirName&"/?"&newsPageListName&"-"&page&fileSuffix
end if
elseif runMode="static" then
if page=1 then
linkStr="/"&sitePath&newsDirName&"/index"&fileSuffix
else
linkStr="/"&sitePath&newsDirName&"/index_"&page&fileSuffix
end if
elseif runMode="forgedStatic" then
if page=1 then
linkStr="/"&sitePath&newsDirName&"/"&newsPageListName&fileSuffix
else
linkStr="/"&sitePath&newsdirname&"/"&newsPageListName&"-"&page&fileSuffix
end if
end if
getNewsChannelLink=linkStr
End Function
Function getContentLink(Byval typeId,Byval videoId,Byval linkType)
dim linkStr,typePath
if runMode="dynamic" then
linkStr="/"&sitePath&contentDirName1&"/?"&videoId&fileSuffix
elseif runMode="static" and makeMode="dir1" then
typePath=getTypePathOnCache(typeId)
if md5Content=1 then videoId=md5(videoId,16)
if isNul(linkType) then linkStr="/"&sitePath&typePath&videoId&"/"&contentPageName2&fileSuffix else linkStr="/"&sitePath&typePath&videoId&"/"
elseif runMode="static" and makeMode="dir2" then
if md5Content=1 then
videoId=md5(videoId,16)
linkStr="/"&sitePath&contentDirName3&"/"&videoId&fileSuffix
else
linkStr="/"&sitePath&contentDirName3&"/"&contentPageName3&videoId&fileSuffix
end if
elseif runMode="forgedStatic" then
linkStr="/"&sitePath&contentDirName4&"/"&contentPageName4&videoId&fileSuffix
end if
getContentLink=linkStr
End Function
Function getPlayLink(Byval typeId,Byval videoId)
dim linkStr,typePath
if runMode="static" and ismakeplay=0 then getPlayLink="/"&sitePath&playDirName1&"/?"&videoId:Exit Function
if runMode="dynamic" then
linkStr="/"&sitePath&playDirName1&"/?"&videoId
elseif runMode="static" and makeMode="dir1" then
typePath=getTypePathOnCache(typeId)
if md5Content=1 then videoId=md5(videoId,16)
linkStr="/"&sitePath&typePath&videoId&"/"&playPageName2&fileSuffix
elseif runMode="static" and makeMode="dir2" then
if md5Content=1 then videoId=md5(videoId,16):linkStr="/"&sitePath&playDirName3&"/"&videoId&fileSuffix else linkStr="/"&sitePath&playDirName3&"/"&playPageName3&videoId&fileSuffix
elseif runMode="forgedStatic" then
linkStr="/"&sitePath&playDirName4&"/"&videoId
end if
getPlayLink=linkStr
End Function
Function getPlayLink2(typeId,vId)
dim contactStr,behindStr
if runMode="dynamic" or ismakeplay=0 then
contactStr="":behindStr=fileSuffix
elseif runMode="static" then
contactStr="?"&vId:behindStr=""
elseif runMode="forgedStatic" then
contactStr="":behindStr=fileSuffix
end if
getPlayLink2=getPlayLink(typeId,vId)&contactStr&"-0-0"&behindStr
End Function
Function getPlayerParas()
Dim paras:paras=Split(replaceStr(request.QueryString,fileSuffix,""),"-")
if UBound(paras)>1 then
getPlayerParas=array(paras(1),paras(2))
else
getPlayerParas=array(-1,-1)
end if
End Function
Function getPlayUrlList(Byval ifrom,Byval url,Byval typeId,Byval vId,Byval typestr,ByVal starget)
dim urlArray,singleUrlArray,urlCount,i,urlStr,contactStr,behindStr,style,paras,target:paras=getPlayerParas()
if runMode="dynamic" or ismakeplay=0 then
contactStr="":behindStr=fileSuffix
elseif runMode="static" then
contactStr="?"&vId:behindStr=""
elseif runMode="forgedStatic" then
contactStr="":behindStr=fileSuffix
end if
if isNul(url) then
getPlayUrlList="" : Exit Function
else
if ""&starget<>"" then
target=" target="""&starget&""""
else
target=" target=""_blank"""
end if
urlArray=split(url,"#")
urlCount=ubound(urlArray)
urlStr="
"
for i=0 to urlCount
if not isNul(urlArray(i)) then
singleUrlArray=split(urlArray(i),"$")
if ubound(singleUrlArray)<2 then singleUrlArray=Array("","","")
if ""¶s(0)=""&ifrom AND ""&i=""¶s(1) then style=" style=""color:red""" else style=""
select case typestr
case "play"
if isAlertWin=1 then
urlStr=urlStr&"
"
end select
end if
next
end if
getPlayUrlList=urlStr&"
"
End Function
Function getIndexLink()
if runMode="dynamic" then
getIndexLink="/"&sitePath
elseif runMode="static" and makeMode="dir1" then
getIndexLink="/"&sitePath
elseif runMode="static" and makeMode="dir2" then
getIndexLink="/"&sitePath
elseif runMode="forgedStatic" then
getIndexLink="/"&sitePath&"index"&fileSuffix
end if
End Function
Function getTopicIndexLink()
if runMode="dynamic" then
getTopicIndexLink="/"&sitePath&topicDirName&"/"
elseif runMode="static" then
getTopicIndexLink="/"&sitePath&topicDirName&"/index"&fileSuffix
elseif runMode="forgedStatic" then
getTopicIndexLink="/"&sitePath&topicDirName4&"/index"&fileSuffix
end if
End Function
'Function getTypePath(id)
' dim m_upid,rsObj,typePath
' set rsObj=conn.db("select m_enname,m_upid from {pre}type where m_id="&id,"records1")
' if clng(rsObj("m_upid"))=0 then
' getTypePath=rsObj("m_enname")&"/":Exit Function
' else
' typePath =getTypePath(rsObj("m_upid"))&rsObj("m_enname")&"/"
' getTypePath=typePath
' end if
' rsObj.close
' set rsObj=nothing
'End Function
Function getTypePath(ByVal id)
Dim i,j,k,l,TL:TL=getTypeLists():j=getTypeindex("m_id"):k=getTypeindex("m_upid"):l=getTypeindex("m_enname"):getTypePath=""
for i=0 to UBound(TL,2)
if ""&TL(j,i)=""&id then
if clng(TL(k,i))=0 then
getTypePath=TL(l,i)&"/":Exit Function
else
getTypePath=getTypePath(TL(k,i))&TL(l,i)&"/"
end if
end if
next
End Function
Dim gTypePathCache
Function getTypePathOnCache(id)
dim cacheName,pathStr:cacheName="str_get_curtype_dir_type"&id
if not isArray(gTypePathCache) then ReDim gTypePathCache(1)
if gTypePathCache(0)<>id then
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then pathStr=cacheObj.getCache(cacheName) else pathStr=getTypePath(id):cacheObj.setCache cacheName,pathStr end if
else
pathStr=getTypePath(id)
end if
gTypePathCache(0)=id:gTypePathCache(1)=pathStr
end if
getTypePathOnCache=gTypePathCache(1)
End Function
'Function getTypeText(id)
' dim m_upid,rsObj,typeText,indexStr
' indexStr="首页 » "
' set rsObj=conn.db("select m_id,m_name,m_enname,m_upid from {pre}type where m_id="&id,"records1")
' if rsObj("m_upid")=0 then
' getTypeText=indexStr&""&rsObj("m_name")&"":Exit Function
' else
' typeText =getTypeText(rsObj("m_upid"))&" » "&""&rsObj("m_name")&""
' getTypeText=typeText
' end if
' rsObj.close
' set rsObj=nothing
'End Function
Function getTypeText(id)
Dim i,j,k,l,TL:TL=getTypeLists():j=getTypeindex("m_id"):k=getTypeindex("m_upid"):l=getTypeindex("m_name"):getTypeText=""
for i=0 to UBound(TL,2)
if ""&TL(j,i)=""&id then
if clng(TL(k,i))=0 then
getTypeText="首页 » "&TL(l,i)&"":Exit Function
else
getTypeText=getTypeText(TL(k,i))&" » "&TL(l,i)&""
end if
end if
next
End Function
dim gTypeTextOnCache
Function getTypeTextOnCache(id)
dim cacheName,typeText:cacheName="str_get_curtype_location_type"&id
if not isArray(gTypeTextOnCache) then ReDim gTypeTextOnCache(1)
if gTypeTextOnCache(0)<>id then
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then typeText=cacheObj.getCache(cacheName) else typeText=getTypeText(id):cacheObj.setCache cacheName,typeText end if
else
typeText=getTypeText(id)
end if
gTypeTextOnCache(0)=id:gTypeTextOnCache(1)=typeText
end if
getTypeTextOnCache=gTypeTextOnCache(1)
End Function
'Function getTypeId(id)
' dim m_upid,rsObj,typeid,i
' set rsObj=conn.db("select m_id,m_upid from {pre}type where m_upid="&id,"records1")
' if rsObj.eof then
' getTypeId=id : Exit Function
' else
' for i=1 to rsObj.recordcount
' typeid =typeid&","&getTypeId(rsObj("m_id"))
' rsObj.movenext
' next
' getTypeId=id&typeid
' end if
' rsObj.close
' set rsObj=nothing
'End Function
Function getTypeId(ByVal id)
dim i,j,k,TL,ret:TL=getTypeLists():j=getTypeIndex("m_upid"):k=getTypeIndex("m_id"):ret=""
if Clng(id)>0 then:ret=id
for i=0 to UBound(TL,2)
if ""&TL(j,i)=""&id then
if ret="" then
ret=getTypeId(TL(k,i))
else
ret=ret&","&getTypeId(TL(k,i))
end if
end if
next
getTypeId=ret
End Function
Function getTypeIdOnCache(Byval id)
dim cacheName,typeid
cacheName="str_get_subtypes_type"&id
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then typeid=cacheObj.getCache(cacheName) else typeid=getTypeId(id):cacheObj.setCache cacheName,typeid
else
typeid=getTypeId(id)
end if
getTypeIdOnCache=typeid
End Function
'Function getAllMenuList(id)
' dim listStr,typeArray,smallTypeArray,m,i
' typeArray=conn.db("select m_name,m_id from {pre}type where m_upid="&id&" order by m_sort asc","array")
' if not isArray(typeArray) then
' getAllMenuList="" : Exit Function
' else
' listStr="
"
' for i=0 to ubound(typeArray,2)
' listStr=listStr&"
"
' end if
' getAllMenuList=listStr
'End Function
Function getAllMenuList(ByVal id)
Dim i,j,k,l,TL,s:TL=getTypeLists():j=getTypeindex("m_upid"):k=getTypeindex("m_id"):l=getTypeindex("m_name"):getAllMenuList="":s=""
for i=0 to UBound(TL,2)
if ""&TL(j,i)=""&id then
s=s&"
":end if
End Function
Function getAllMenuListOnCache(id)
dim cacheName,menuList
cacheName="str_menu_list"&id
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then menuList=cacheObj.getCache(cacheName) else menuList=getAllMenuList(id) : cacheObj.setCache cacheName,menuList
else
menuList=getAllMenuList(id)
end if
getAllMenuListOnCache=menuList
End Function
Dim gTypearray
Function getTypeListsArray()
if Not isArray(gTypearray) then
Dim Rows:Rows=conn.db("SELECT m_id,m_name,m_enname,m_sort,m_upid,m_hide,m_template,m_unionid,-1 AS m_count FROM {pre}type ORDER BY m_sort ASC","array")
if isArray(Rows) then
gTypearray=Rows
else
Redim gTypearray(8,-1)
end if
end if
getTypeListsArray=gTypearray
End Function
Function getTypeLists()
Dim cacheName:cacheName="array_Type_Lists_all"
if cacheStart=1 AND not isArray(gTypearray) then
if cacheObj.chkCache(cacheName) then gTypearray=cacheObj.getCache(cacheName) else cacheObj.setCache cacheName,getTypeListsArray()
end if
getTypeLists=getTypeListsArray()
End Function
Function getNumPerType(ByVal id)
dim ids,num,i,j,l,Bool:j=getTypeIndex("m_id"):l=getTypeIndex("m_count"):num=0:Bool=false
if not isArray(gTypearray) then:getTypeLists():end if
ids = " ,"&Replace(getTypeIdOnCache(id)," ","")&","
for i=0 to UBound(gTypearray,2)
if InStr(ids,","&trim(gTypearray(j,i))&",")>0 then
gTypearray(l,i)=Clng(gTypearray(l,i))
if gTypearray(l,i)=-1 then:gTypearray(l,i)=conn.db("select count(*) from {pre}data where m_type="&gTypearray(j,i),"execute")(0):end if
num=num+Clng(gTypearray(l,i)):Bool=true
end if
next
if Bool=true then
if cacheStart=1 then
cacheObj.setCache "array_Type_Lists_all",gTypearray
end if
end if
getNumPerType = num
End Function
Function getTypeindex(ByVal sName)
dim i
SELECT Case sName
Case "m_id":i=0
Case "m_name":i=1
Case "m_enname":i=2
Case "m_sort":i=3
Case "m_upid":i=4
Case "m_hide":i=5
Case "m_template":i=6
Case "m_unionid":i=7
Case "m_count":i=8
End SELECT
getTypeindex=i
End Function
Dim gHideTypeIDS:gHideTypeIDS=empty
Function getHideTypeIDS()
if gHideTypeIDS=empty then
Dim i,j,k,ret,TS:TS=getTypeLists():j=getTypeIndex("m_hide"):k=getTypeIndex("m_id"):ret=""
for i=0 to UBound(TS,2)
if ""&TS(j,i)="1" then
if ret="" then
ret=TS(k,i)
else
ret=ret&","&TS(k,i)
end if
end if
next
gHideTypeIDS=ret
end if
getHideTypeIDS=gHideTypeIDS
End Function
dim span : span=""
Sub makeTypeOption(topId,separateStr)
Dim i,j,k,m,TL:TL=getTypeLists():j=getTypeindex("m_id"):k=getTypeindex("m_upid"):m=getTypeindex("m_name")
for i=0 to UBound(TL,2)
if ""&TL(k,i)=""&topId then
if topId<>0 then span=span&separateStr
echo ""
makeTypeOption TL(j,i),separateStr
end if
next
if not isNul(span) then span=left(span,len(span)-len(separateStr))
End Sub
'yuet 2009-10-10 18:30 优化递归查询,下面旧函不用了
'Sub makeTypeOption(topId,separateStr)
' dim sqlStr,rsObj
' sqlStr= "select m_id,m_name from {pre}type where m_upid="&topId&" order by m_sort asc"
' set rsObj=conn.db(sqlStr,"records1")
' do while not rsObj.eof
' if topId<>0 then span=span&separateStr
' echo ""
' makeTypeOption rsObj("m_id"),separateStr
' rsObj.movenext
' loop
' if not isNul(span) then span=left(span,len(span)-len(separateStr))
' rsObj.close
' set rsObj=nothing
'End Sub
Sub makeTypeSelect(selectName)
echo ""
End Sub
Function makeTopicSelect(selectName,arrayObj,strSelect,topicId)
dim i,str,selectedStr
str=""
makeTopicSelect=str
End Function
Function makeTopicOptions(arrayObj,strSelect)
dim i,str
if not isNul(str) then str=str&""
if isArray(arrayObj) then
for i=0 to ubound(arrayObj,2)
str=str&""
next
end if
makeTopicOptions=str
End Function
Function arrayToDictionay(Byval arrayObj)
dim dictionaryObj : set dictionaryObj=server.CreateObject(DICTIONARY_OBJ_NAME)
dim dicKey,dicValue,i
if isArray(arrayObj) then
for i=0 to ubound(arrayObj,2)
dicKey= arrayObj(0,i) : dicValue= arrayObj(1,i)
if not dictionaryObj.Exists(dicKey) then dictionaryObj.add dicKey,dicValue else dictionaryObj(dicKey)=dicValue
next
end if
set arrayToDictionay=dictionaryObj
End Function
'Function typeArrayToDictionay(Byval arrayObj)
' dim dictionaryObj : set dictionaryObj=server.CreateObject(DICTIONARY_OBJ_NAME)
' dim dicKey,dicValue,i
' if isArray(arrayObj) then
' for i=0 to ubound(arrayObj,2)
' dicKey= arrayObj(0,i) : dicValue= arrayObj(1,i)&","&arrayObj(2,i)&","&arrayObj(3,i)
' if not dictionaryObj.Exists(dicKey) then dictionaryObj.add dicKey,dicValue else dictionaryObj(dicKey)=dicValue
' next
' end if
' set typeArrayToDictionay=dictionaryObj
'End Function
Function typeArrayToDictionay()
dim dictionaryObj,TS : set dictionaryObj=server.CreateObject(DICTIONARY_OBJ_NAME):TS=getTypeLists()
dim dicKey,dicValue,i,j,k,l,m:j=getTypeIndex("m_id"):k=getTypeIndex("m_name"):l=getTypeIndex("m_enname"):m=getTypeIndex("m_upid")
if isArray(TS) then
for i=0 to ubound(TS,2)
dicKey= TS(j,i) : dicValue= TS(k,i)&","&TS(l,i)&","&TS(m,i)
if not dictionaryObj.Exists(dicKey) then dictionaryObj.add dicKey,dicValue else dictionaryObj(dicKey)=dicValue
next
end if
set typeArrayToDictionay=dictionaryObj
End Function
'Function getTypeNameTemplateArrayOnCache(m_id)
' dim cacheName,typeArray,elementId
' cacheName="array_type_id_name_template_upid"
' if cacheStart=1 then
' if cacheObj.chkCache(cacheName) then typeArray=cacheObj.getCache(cacheName) else typeArray=conn.db("select m_id,m_name,m_template,m_upid from {pre}type order by m_sort asc","array") : cacheObj.setCache cacheName,typeArray
' else
' typeArray=conn.db("select m_id,m_name,m_template,m_upid from {pre}type order by m_sort asc","array")
' end if
' elementId=getArrayElementID(typeArray,0,m_id)
' getTypeNameTemplateArrayOnCache=typeArray(1,elementId)&","&typeArray(2,elementId)&","&typeArray(3,elementId)
'End Function
Function getTypeNameTemplateArray(m_id)
dim typeArray,i,j,ret:j=getTypeIndex("m_id"):ret="":typeArray=getTypeLists()
for i=0 to UBound(typeArray,2)
if ""&typeArray(j,i)=""&m_id then
ret=typeArray(getTypeIndex("m_name"),i)&","&typeArray(getTypeIndex("m_template"),i)&","&typeArray(getTypeIndex("m_upid"),i):exit for
end if
next
getTypeNameTemplateArray=ret
End Function
Function getTypeNameTemplateArrayOnCache(m_id)
dim cacheName,ret:cacheName="array_type_id_name_template_upid"&m_id
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then ret=cacheObj.getCache(cacheName) else ret=getTypeNameTemplateArray(m_id) : cacheObj.setCache cacheName,ret
else
ret=getTypeNameTemplateArray(m_id)
end if
getTypeNameTemplateArrayOnCache=ret
End Function
Sub echoSaveStr(ptype)
dim cssstr
cssstr=""
select case ptype
case "safe"
die cssstr&"
【警告】非法提交：
你提交的数据有非法字符，你的IP【"&getIp&"】已被记录,操作时间:"&now()&"
Powered By "&siteName&"
"
case "null"
die cssstr&"
【警告】参数错误：
错误描述：参数为空或不正确
Powered By "&siteName&"
"
end Select
cssstr=""
End Sub
Function preventSqlin(content,vtype)
dim sqlStr,sqlArray,i,speStr
sqlStr="<|>|%|%27|'|''|;|*|and|exec|dbcc|alter|drop|insert|select|update|delete|count|master|truncate|char|declare|where|set|declare|mid|chr"
if isNul(content) then Exit Function
sqlArray=split(sqlStr,"|")
for i=lbound(sqlArray) to ubound(sqlArray)
if instr(lcase(content),sqlArray(i))<>0 then
if vtype="filter" then
select case sqlArray(i)
case "<":speStr="<"
case ">":speStr=">"
case "'","""":speStr="""
case ";":speStr="；"
case else:speStr=""
end select
content=replace(content,sqlArray(i),speStr,1,-1,1)
else
echoSaveStr "safe" : Exit Function
end if
end if
next
preventSqlin=content
End Function
Function replaceCurrentTypeId(str)
str=replaceStr(str,"{maxcms:currenttypeid}",currentTypeId)
replaceCurrentTypeId=str
End Function
Sub checkRunMode
if runMode<>"static" then die "
网站运行模式非静态，不允许生成
"
End Sub
Sub isCurrentDay(timeStr)
if isNul(timeStr) then echo "":Exit Sub
dim timeStr2 : timeStr2=date
if instr(timeStr,timeStr2)>0 then echo ""&timeStr&"" else echo ""&timeStr&""
End Sub
Function getFromStr(playurl)
if isNul(playurl) then getFromStr="" : Exit Function
dim playurlArray,playurlLen,i,span1,span2,urlstr : span1="$$$" : span2="$$"
playurlArray=split(playurl,span1) : playurlLen=ubound(playurlArray)
for i=0 to playurlLen
if i=playurlLen then urlstr=urlstr&split(playurlArray(i),span2)(0) else urlstr=urlstr&split(playurlArray(i),span2)(0)&","
next
getFromStr=urlstr
End Function
Function getPlayurlArray(playurl)
dim span1 : span1="$$$"
if isNul(playurl) then playurl=""
getPlayurlArray=split(playurl,span1)
End Function
Function filterDirty(content)
dim dirtyStr,dirtyStrArray,i : dirtyStr="%u80E1%u9526%u6D9B%2C%u6E29%u5BB6%u5B9D%2C%u5C3B%2C%u5C4C%2C%u64CD%u4F60%2C%u5E72%u6B7B%u4F60%2C%u8D31%u4EBA%2C%u72D7%u5A18%2C%u5A4A%u5B50%2C%u8868%u5B50%2C%u9760%u4F60%2C%u53C9%u4F60%2C%u53C9%u6B7B%2C%u63D2%u4F60%2C%u63D2%u6B7B%2C%u5E72%u4F60%2C%u5E72%u6B7B%2C%u65E5%u4F60%2C%u65E5%u6B7B%2C%u9E21%u5DF4%2C%u777E%u4E38%2C%u5305%u76AE%2C%u9F9F%u5934%2C%u5C44%2C%u8D51%2C%u59A3%2C%u808F%2C%u5976%u5B50%2C%u5976%u5934%2C%u9634%u6BDB%2C%u9634%u9053%2C%u9634%u830E%2C%u53EB%u5E8A%2C%u5F3A%u5978%2C%u7231%u6DB2%2C%u6027%u9AD8%u6F6E%2C%u505A%u7231%2C%u6027%u4EA4%2C%u53E3%u4EA4%2C%u809B%u4EA4"
dirtyStrArray=split(unescape(dirtyStr),",")
for i=0 to ubound(dirtyStrArray)
content=replace(content,dirtyStrArray(i),"***",1,-1,1)
next
filterDirty=content
End Function
Sub writeFontWaterPrint(saveImgPath,location)
dim jpegObj,strWidth,strHeight,picPath : strWidth=len(waterMarkFont)*5 : strHeight=3
on error resume next
set jpegObj=Server.CreateObject(JPEG_OBJ_NAME)
picPath=Server.MapPath(saveImgPath)
with jpegObj
.Interpolation=2 : .Open picPath : .Canvas.Font.BkMode=true : .Canvas.Font.BkColor=&HFF3300 : .Canvas.Font.Color=&Hffffff : .Canvas.Font.Family="Tahoma" : .Canvas.Font.Size=14 : .Canvas.Font.Bold=true
select case location
case "lefttop" : jpegObj.Canvas.Print 5 , strHeight, waterMarkFont
case "righttop" : jpegObj.Canvas.Print jpegObj.width-strWidth, strHeight, waterMarkFont
case "leftbottom" : jpegObj.Canvas.Print 5 , jpegObj.height-20, waterMarkFont
case "rightbottom" : jpegObj.Canvas.Print jpegObj.width-strWidth, jpegObj.height-20, waterMarkFont
case "middle" : jpegObj.Canvas.Print (jpegObj.width-strWidth)/2, (jpegObj.height-strHeight)/2, waterMarkFont
end select
.Canvas.Pen.Color=&Heeeeee : .Canvas.Pen.Width=1 : .Canvas.Brush.Solid=False : .Canvas.Bar 0, 0, jpegObj.Width, jpegObj.Height : .Save picPath
end with
set jpegObj=nothing : if err then err.clear
End Sub
Function regexFind(Byval str,Byval pattern)
if isNul(str) then : regexFind="" : Exit Function
dim regObj,match,matches,findStr : set regObj=New RegExp
regObj.Pattern=pattern : set matches=regObj.Execute(str)
for each match in matches
regexFind=match.SubMatches(0)
set regObj=nothing : set matches=nothing : Exit Function
next
End Function
Function getTimeSpan(sessionName)
dim lastTime : lastTime=session(sessionName)
if isNul(lastTime) then lastTime=0
getTimeSpan=DateDiff("s",lasttime,now())
End Function
Sub setSession(sessionName,sessionValue)
session(sessionName)=sessionValue
End Sub
Function showFace(m_content)
dim templateobj : set templateobj=mainClassObj.createObject("mainclass.template")
m_content=templateobj.regExpReplace(m_content,"\[ps:(\d{1,})?\]","")
set templateobj=nothing
showFace=m_content
End Function
Function isExistStr(str,findstr)
if isNul(str) or isNul(findstr) then isExistStr=false:Exit Function
if instr(str,findstr)>0 then isExistStr=true else isExistStr=false
End Function
Sub parseLabelHaveLen(Byval str,Byval label)
dim bLabel,eLabel,strBegin,strLen,regObj,match,matches,strByLen
set regObj=New RegExp:regObj.ignoreCase=true:regObj.Global=true:regObj.Pattern="\{playpage:"&label&"\s+len=(\d+)?\s*\}"
if regObj.Test(templateObj.content) then
set matches=regObj.Execute(templateObj.content)
for each match in matches
strLen=match.SubMatches(0)
if label="actor" then strByLen=getKeywordsList(left(str,strLen)," ") else strByLen=left(str,strLen)
if label="des" then strByLen=filterStr(codeTextarea(strByLen,"en"),"html")
templateObj.content=replaceStr(templateObj.content,match.value,strByLen)
next
set matches =nothing:set regObj=nothing
else
exit sub
end if
set regObj=nothing
End Sub
Function getFirstLetter(str)
dim temNum,char : char=left(replace(trim(str)," ",""),1)
on error resume next
temNum=65536+asc(char)
if err then getFirstLetter="":err.clear:exit function
IF (temNum>=45217 and temNum<=45252) Then
getFirstLetter= "A"
ElseIF(temNum>=45253 and temNum<=45760) Then
getFirstLetter= "B"
ElseIF(temNum>=45761 and temNum<=46317) Then
getFirstLetter= "C"
ElseIF(temNum>=46318 and temNum<=46825) Then
getFirstLetter= "D"
ElseIF(temNum>=46826 and temNum<=47009) Then
getFirstLetter= "E"
ElseIF(temNum>=47010 and temNum<=47296) Then
getFirstLetter= "F"
ElseIF(temNum>=47297 and temNum<=47613) Then
getFirstLetter= "G"
ElseIF(temNum>=47614 and temNum<=48118) Then
getFirstLetter= "H"
ElseIF(temNum>=48119 and temNum<=49061) Then
getFirstLetter= "J"
ElseIF(temNum>=49062 and temNum<=49323) Then
getFirstLetter= "K"
ElseIF(temNum>=49324 and temNum<=49895) Then
getFirstLetter= "L"
ElseIF(temNum>=49896 and temNum<=50370) Then
getFirstLetter= "M"
ElseIF(temNum>=50371 and temNum<=50613) Then
getFirstLetter= "N"
ElseIF(temNum>=50614 and temNum<=50621) Then
getFirstLetter= "O"
ElseIF(temNum>=50622 and temNum<=50905) Then
getFirstLetter= "P"
ElseIF(temNum>=50906 and temNum<=51386) Then
getFirstLetter= "Q"
ElseIF(temNum>=51387 and temNum<=51445) Then
getFirstLetter= "R"
ElseIF(temNum>=51446 and temNum<=52217) Then
getFirstLetter= "S"
ElseIF(temNum>=52218 and temNum<=52697) Then
getFirstLetter= "T"
ElseIF(temNum>=52698 and temNum<=52979) Then
getFirstLetter= "W"
ElseIF(temNum>=52980 and temNum<=53688) Then
getFirstLetter= "X"
ElseIF(temNum>=53689 and temNum<=54480) Then
getFirstLetter= "Y"
ElseIF(temNum>=54481 and temNum<=62289) Then
getFirstLetter= "Z"
ElseIF(temNum=-2354+65536) Then
getFirstLetter= "X"
Else
getFirstLetter=UCase(char)
End if
End Function
Function replacedirtyWords(str)
dim i
dim mystr : mystr=str
dim warray : warray=split(dirtyWords,",")
for i=0 to ubound(warray)
mystr=replace(mystr,warray(i),"*")
next
replacedirtyWords=mystr
End Function
Function getletterlist
dim i,mystr
for i=65 to 90
mystr=mystr&""&chr(i)&""
next
getletterlist=mystr
End Function
Function writeRole
writeRole=false
createTextFile "","role.asp",""
if objFso.FileExists(server.mappath("role.asp")) then writeRole=true : delFile "role.asp"
End Function
Function getNewsFolder(vdate)
if isnul(vdate) then vdate=now
if isdate(vdate)=false then vdate=now
if month(vdate)<10 then getNewsFolder=year(vdate)&"0"&month(vdate) else getNewsFolder=year(vdate)&month(vdate)
End Function
Function getSubStrByFromAndEnd(str,startStr,endStr,operType)
dim location1,location2
select case operType
case "start"
location1=instr(str,startStr)+len(startStr):location2=len(str)+1
case "end"
location1=1:location2=instr(location1,str,endStr)
case else
location1=instr(str,startStr)+len(startStr):location2=instr(location1,str,endStr)
end select
getSubStrByFromAndEnd=mid(str,location1,location2-location1)
End Function
Function getPlayerIntroArray(str)
dim xmlobj,vNodes,i,j,l,xmlFile,xmlNode,tmp
ReDim temp(2,0)
if str="play" then
xmlFile="/"&sitePath&"inc/playerkinds.xml":xmlNode="playerkinds/player"
else
xmlFile="/"&sitePath&"inc/downkinds.xml":xmlNode="downkinds/source"
end if
set xmlobj = mainClassobj.createObject("mainclass.Xml")
xmlobj.load xmlFile,"xmlfile"
set vNodes=xmlobj.getNodes(xmlNode):l=vNodes.length-1
for i=0 to l
ReDim Preserve temp(2,i)
temp(0,i)=xmlobj.getAttributesByNode(vNodes(i),"flag")
temp(1,i)=vNodes(i).childNodes(0).text&"__maxcc__"&xmlobj.getAttributesByNode(vNodes(i),"open")
temp(2,i)=xmlobj.getAttributesByNode(vNodes(i),"sort")
if isNumeric(temp(2,i)) then:temp(2,i)=Clng(temp(2,i)):else:temp(2,i)=0:end if
next
set vNodes=nothing:set xmlobj=nothing
for i=0 to l
for j=i+1 to l
if temp(2,i) < temp(2,j) then
tmp=temp(0,j):temp(0,j)=temp(0,i):temp(0,i)=tmp
tmp=temp(1,j):temp(1,j)=temp(1,i):temp(1,i)=tmp
tmp=temp(2,j):temp(2,j)=temp(2,i):temp(2,i)=tmp
end if
next
next
getPlayerIntroArray=temp
End Function
Dim gPlayerIntroArray(1)
Function getPlayerIntroArrayOnCache(str)
Dim i:if str="play" then:i=0:else:i=1:end if
if not isArray(gPlayerIntroArray(i)) then
dim cacheName,playerArray:cacheName="array_"&str&"list"
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then:gPlayerIntroArray(i)=cacheObj.getCache(cacheName):else:gPlayerIntroArray(i)=getPlayerIntroArray(str):cacheObj.setCache cacheName,gPlayerIntroArray(i)
else
gPlayerIntroArray(i)=getPlayerIntroArray(str)
end if
end if
getPlayerIntroArrayOnCache=gPlayerIntroArray(i)
End Function
Function getPlayerIntroOnCache(str,flag)
dim playerArray:playerArray=getPlayerIntroArrayOnCache(str)
getPlayerIntroOnCache=playerArray(1,getArrayElementID(playerArray,0,flag))
End Function
Function getRndPlayerurlSpan(rndType)
dim rndNumber,rndNumber2,rndArray
select case rndType
case 1
randomize():rndNumber=clng(10000*rnd)
randomize():rndNumber2=clng(3*rnd)
select case rndNumber2
case 0
getRndPlayerurlSpan=rndNumber&"'+'"&replaceStr(replaceStr(replaceStr(cacheFlag,"C",""),"_",""),"2009","")&"'+'"&rndNumber
case 1
getRndPlayerurlSpan=rndNumber&"'+'"&replaceStr(replaceStr(replaceStr(cacheFlag,"C",""),"_",""),"2009","")&rndNumber
case 2
getRndPlayerurlSpan=rndNumber&replaceStr(replaceStr(replaceStr(cacheFlag,"C",""),"_",""),"2009","")&"'+'"&rndNumber
case 3
getRndPlayerurlSpan=rndNumber&replaceStr(replaceStr(replaceStr(cacheFlag,"C",""),"_",""),"2009","")&rndNumber
end select
case 2
randomize():rndNumber=clng(3*rnd)
rndArray=Array("un"&"esc"&"ape('%2524')+u"&"nesca"&"pe('%25')+unes"&"cape('24')","un"&"esc"&"ape('%25')+u"&"nesca"&"pe('24%25')+unes"&"cape('24')","u"&"nesca"&"pe('%2524')+un"&"esc"&"ape('%2524')","unes"&"cape('%2524%2524')")
getRndPlayerurlSpan=rndArray(rndNumber)
end select
End Function
Function getTextsegments()
Dim l,ret,xmlobj,Nodes,Node:ret=array():SET xmlobj=mainClassobj.createObject("mainclass.xml"):l=0
xmlobj.load "/"&sitePath&"inc/textsegment.xml","xmlfile"
SET Nodes=xmlobj.getNodes("root/item")
for each Node in Nodes
ReDim Preserve ret(l)
ret(l)=Node.text:l=l+1
next
set xmlobj = nothing:getTextsegments=ret
End Function
Function getTextsegmentsOnCache()
dim cacheName,ret:cacheName="array_textsegmentlist"
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then ret=cacheObj.getCache(cacheName) else ret=getTextsegments():cacheObj.setCache cacheName,ret
else
ret=getTextsegments()
end if
getTextsegmentsOnCache=ret
End Function
Function doPseudo(ByVal des,ByVal iId)
dim iType,ts,l,pos:iType=iId MOD 3:ts=getTextsegmentsOnCache():l=UBound(ts)+1
if l=0 OR des="" then
doPseudo=des
elseif iType=1 then
doPseudo=ts(iId MOD l)&des
elseif iType=2 then
doPseudo=des&ts(iId MOD l)
else
pos=inStr(des," ")
if pos=0 then pos=inStr(des," ")
if pos=0 then pos=inStr(des," ")
if pos=0 then pos=inStr(des,vbcrlf)
if pos=0 then pos=inStr(des,"。")+1
if pos>0 then
doPseudo=Mid(des,1,pos-1)&ts(iId MOD l)&Mid(des,pos)
else
doPseudo=ts(iId MOD l)&des
end if
end if
End Function
%>
<%
'******************************************************************************************
' Software name: Max(马克斯) Content Management System
' Version:2.8
' Web: http://maxcms.bokecc.com
' Author: 石头(maxcms2008@qq.com),yuet,长明,酒瓶
' Copyright (C) 2005-2009 北京梦之窗数码科技有限公司 版权所有
' 法律申明：MaxCMS程序所有代码100%原创、未引入任何网上代码,对一切抄袭行为、坚决严肃追究法律责任
'******************************************************************************************
dim err_dbconect,err_rsopen,err_cachename,err_cachevalue,err_stmobj,err_fsoobj,err_loadfile,err_replace,err_primarykey,err_table,err_writefile,err_createFolder,err_delFolder,err_delFile,err_notExistFolder,err_moveFolder,err_xmlHttp,err_xml,err_areaList,channellistInfo(1),searchlistInfo(1),pageRunStr(2),topicpageInfo(0),newspageInfo(0)
err_dbconect="数据库连接错误"
err_rsopen="执行SQL语句错误"
err_cachename="请设置缓存名称"
err_cachevalue="缓存值不存在"
err_stmobj="st"&"ream对象实例创建失败"
err_fsoobj="F"&"SO对象实例创建失败"
err_loadfile="加载文件失败"
err_replace="字符串替换发生错误"
err_primarykey="数据列表未指定主键"
err_table="数据列表未指定表"
err_writefile="写入文件失败"
err_createFolder="创建文件夹失败"
err_delFolder="删除文件夹失败"
err_delFile="删除文件失败"
err_notExistFolder="文件夹不存在"
err_moveFolder="移动文件夹失败"
err_xmlHttp="您的服务器无法访问外网"
err_xml = "加载xml发生错误"
err_areaList="循环标签分类设置错误"
newspageInfo(0)=" 对不起，无任何新闻 "
topicpageInfo(0)=" 对不起，该专题无记录任何记录 "
channellistInfo(0)=" 对不起，该分类无记录任何记录 ":channellistInfo(1)="指定分类错误"
searchlistInfo(0)="对不起，没有找到任何记录,请您在此留言，我们尽快为你添加喜欢的电影"
pageRunStr(0)="页面执行时间: ":pageRunStr(1)="秒 ":pageRunStr(2)="次数据查询"
%>
<%
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function md5_F(x, y, z)
md5_F = (x And y) Or ((Not x) And z)
End Function
Private Function md5_G(x, y, z)
md5_G = (x And z) Or (y And (Not z))
End Function
Private Function md5_H(x, y, z)
md5_H = (x Xor y Xor z)
End Function
Private Function md5_I(x, y, z)
md5_I = (y Xor (x Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage,slength)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, x(k + 10), S22, &H2441453
md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, &HF4292244
md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, x(k + 6), S43, &HA3014314
md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
if slength =32 then
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
else
MD5=LCase(WordToHex(b))& WordToHex(c)
end if 'I crop this to fit 16byte database password :D
End Function
Function Zt(showid)
Zt=showid
End Function
%>
<%
dim mainClassObj
set mainClassObj=New MainClass
dim conn
set conn=mainClassobj.createObject("MainClass.DB")
if databaseType =0 then conn.dbType="acc" else conn.dbType="sql"
dim objFso,objStream
initializeAllObjects
dim cacheObj
set cacheObj=mainClassObj.createObject("MainClass.Cache")
dim currentTypeId : currentTypeId=-444
dim currrent_topic_id : currrent_topic_id=-444
dim pageUrlStyle
%>
<%
'******************************************************************************************
' Software name: Max(马克斯) Content Management System
' Version:2.8
' Web: http://maxcms.bokecc.com
' Author: 石头(maxcms2008@qq.com),yuet,长明,酒瓶
' Copyright (C) 2005-2009 北京梦之窗数码科技有限公司 版权所有
' 法律申明：MaxCMS程序所有代码100%原创、未引入任何网上代码,对一切抄袭行为、坚决严肃追究法律责任
'******************************************************************************************
dim searchLimitFlag,searchtime:searchLimitFlag=0:searchtime=5'searchLimitFlag为显示搜索控制标识(0不开启,1开启),searchtime为搜索间隔秒数
dim action : action = getForm("action", "get")
dim searchTemplatePath, templateobj : set templateobj = mainClassobj.createObject("MainClass.template")
dim searchword,searchType,page : searchword=getForm("searchword","both") : searchType=getForm("searchtype","both") : page=getForm("page","both")
if isNul(searchType) then
searchType=-1
else
if isNum(searchType) then searchType=clng(searchType) else echoSaveStr "safe"
end if
if isNul(page) then
page=1
else
if isNum(page) then page=clng(page) else echoSaveStr "safe"
end if
searchword=preventSqlin(filterStr(searchword,"html"),"") : if len(searchword)>20 then searchword=left(searchword,20)
echoSearchPage
set templateobj=nothing : terminateAllObjects
Sub echoSearchPage
dim i,cacheName,pSize,rsObj,whereStr,curTypeId,pCount,searchTemplateName,tempStr,searchPageStr
if isNul(searchword) then echoMsgAndGo "请输入搜索关键字",searchtime:die ""
if searchLimitFlag=1 then checkSearchTimes
searchTemplateName="search.html"
searchTemplatePath = "/"&sitePath&"template/"&defaultTemplate&"/"&templateFileFolder&"/"&searchTemplateName
pSize = getPageSizeOnCache(searchTemplatePath,"search","") : if isNul(pSize) then pSize=12
select case clng(searchType)
case -1 : whereStr=" where m_name like '%"&searchword&"%' or m_actor like '%"&searchword&"%' or m_publisharea like '%"&searchword&"%' or m_publishyear like '%"&searchword&"%'"
case 0 : whereStr=" where m_name like '%"&searchword&"%'"
case 1 : whereStr=" where m_actor like '%"&searchword&"%'"
case 2 : whereStr=" where m_publisharea like '%"&searchword&"%'"
case 3 : whereStr=" where m_publishyear like '%"&searchword&"%'"
case 4 : whereStr=" where m_letter = '"&UCase(searchword)&"'"
end select
set rsObj = conn.db("select m_id from {pre}data "&whereStr,"records1")
rsObj.pagesize = pSize
cacheName="parse_search_"
if cacheStart=1 then
if cacheObj.chkCache(cacheName) then
templateObj.content = cacheObj.getCache(cacheName)
else
parseSearchPart
cacheObj.setCache cacheName,templateObj.content
end if
else
parseSearchPart
end if
tempStr = templateObj.content: pCount = rsObj.pagecount
tempStr=replaceStr(tempStr,"{maxcms:searchword}",searchword) : tempStr=replaceStr(tempStr,"{maxcms:searchnum}",rsObj.recordcount)
with templateObj : .content=tempStr : .ParsePageList "",page,pCount,"search" : .content=replaceCurrentTypeId(.content) : .parseIf() : searchPageStr = .content : end with
echo replaceStr(searchPageStr,"{maxcms:runinfo}",getRunTime())
rsObj.close
set rsObj = nothing
End Sub
Sub parseSearchPart
with templateObj
.load(searchTemplatePath) : .parseTopAndFoot() : .parseSelf() : .parseGlobal() : .parseMenuList("") :.parseNewsList: .parseVideoList() : .parseTopicList()
end with
End Sub
Sub checkSearchTimes
if not isNul(getForm("searchword", "post")) then
if rCookie("maxcms2_search")="ok" then echoMsgAndGo "搜索限制为"&searchtime&"秒一次",searchtime:die ""
wCookieInTime "maxcms2_search","ok","s",searchtime
'echo "