%
'****************************************************
' Software name:Kesion CMS 7.0
' Email: service@kesion.com . QQ:111394,9537636
' Web: http://www.kesion.com http://www.kesion.cn
' Copyright (C) Kesion Network All Rights Reserved.
'****************************************************
Class Refresh
Private KS,KSLabel,DomainStr
public Templates,ModelID,Tid,ItemID rem ModelID 模型ID ItemID 文档ID
public Node,PageContent,NextUrl,PrevUrl,TotalPage rem Node 节点对象,PageContent 分页内容
Private Sub Class_Initialize()
Set KS=New PublicCls
Set KSLabel =New RefreshFunction
DomainStr=Replace(KS.GetDomain,"/961069com/","/")
End Sub
Private Sub Class_Terminate()
Set KS=Nothing
Set KSLabel=Nothing
End Sub
Sub Echo(sStr)
Templates = Templates & sStr
End Sub
Sub EchoLn(sStr)
Templates = Templates & sStr & VbNewLine
End Sub
public Sub Scan(ByVal sTemplate)
If Fcls.RefreshType="Content" Then Call ReplaceHits(sTemplate,ModelID,ItemId) '内容页先替换点击数标签
Dim iPosLast, iPosCur
iPosLast = 1
Dim Tags,Key,yllen
do while (true)
iPosCur = findTags(sTemplate, tags, key, iPosLast,yllen)
if (iPosCur <>0) then
Echo mid(sTemplate,iPosLast, iPosCur - iPosLast)
select case (tags)
case "{$"
Parse sTemplate, key
case "{="
ParseEqual sTemplate, key
end select
iPosLast = yllen + 1
else
Echo Mid(sTemplate, iPosLast)
exit do
end if
loop
End Sub
Function FindTags(sTemplate, byref tags, ByRef key, iPosLast, ByRef yllen)
dim a:a = array("{$", "{=") '定义标签开始标记
dim i, cur, posCur
cur=0
for i=0 to ubound(a)
posCur=instr(iPosLast,sTemplate,a(i))
if (posCur<>0 and (cur=0 or posCur"
case "getsitecountall" echo GetSiteCountAll()
case "getsiteonline" echo ""
case "getpoplogin"
Dim LoginStrxml:LoginStrXml=LFCls.GetConfigFromXML("userlogin","/logintemplate/label","popup")
LoginStrxml=Replace(Replace(LoginStrxml,"{$GetSiteUrl}",DomainStr),"{$GetInstallDir}",DomainStr)
echo LoginStrxml
case "getuserloginbyscript" echo ""
case "gettopuserlogin"
LoginStrXml=LFCls.GetConfigFromXML("userlogin","/logintemplate/label","top")
LoginStrxml=Replace(Replace(LoginStrxml,"{$GetSiteUrl}",DomainStr),"{$GetInstallDir}",DomainStr)
echo LoginStrxml
case "getuserlogin" echo ""
case "getspecial"
Dim SpecialIndexUrl,SpecialDir:SpecialDir = KS.Setting(95)
If Split(KS.Setting(5),".")(1)<>"asp" Then SpecialIndexUrl=DomainStr & SpecialDir Else SpecialIndexUrl=DomainStr & "SpecialIndex.asp"
echo "专题首页"
case "getfriendlink" echo "友情链接"
case "getinstalldir" echo DomainStr
case "getmanagelogin" echo "管理登录"
case "getcopyright" echo KS.Setting(18)
case "getmetakeyword" echo KS.Setting(19)
case "getmetadescript" echo KS.Setting(20)
case "getwebmaster" echo "" & KS.Setting(10) & ""
case "getwebmasteremail" echo KS.Setting(11)
case "getsiteurl" echo DomainStr
case "getclubinstalldir" echo KS.Setting(66)
case "gettopadlist" echo KS.GetClubTopAdList
'================================网站通用参数结束===========================
'====================百度电子地图开始========================
case "mapkey" echo KS.Setting(175)
case "mapcenterpoint"
Dim MapMarker,MarkerArr
MapMarker=GetNodeText("mapmarker")
if Not KS.IsNul(MapMarker) Then
MarkerArr=Split(MapMarker,"|")
echo MarkerArr(0)
Else
echo KS.Setting(176)
End If
case "showmarkerlist"
MapMarker=GetNodeText("mapmarker")
if Not KS.IsNul(MapMarker) Then
MarkerArr=Split(MapMarker,"|")
For i=0 to Ubound(MarkerArr)
echo "point = new BMap.Point(" & MarkerArr(i) & "); " & vbcrlf
echo "addMarker(point, " & i & ");" &vbcrlf
Next
end if
'====================地图结束=====================================
case "channelid" echo ModelID
case "infoid" echo ItemID
case "itemname" echo KS.C_S(ModelID,3)
case "itemunit" echo KS.C_S(ModelID,4)
case "getusername" echo GetNodeText("inputer")
case "getrank" echo Replace(GetNodeText("rank"),"★","")
case "getdate" echo GetNodeText("adddate")
case "getkeytags" echo ReplaceKeyTags(GetNodeText("keywords"))
case "getshowcomment" If GetNodeText("comment")="1" Then echo "
"
case "getwritecomment" If GetNodeText("comment")="1" Then echo ""
case "getprevurl" echo LFCls.GetPrevNextURL(ModelID,ItemID, GetNodeText("tid"), "<","")
case "getnexturl" echo LFCls.GetPrevNextURL(ModelID,ItemID, GetNodeText("tid"), ">","")
'================================文章模型开始================================
case "getarticletitle" echo LFCls.ReplaceDBNull(GetNodeText("fulltitle"),GetNodeText("title"))
case "getarticlesize"
echoln ""
echoln "【字体:大中小】"
case "getarticlecontent"
echoln ReplaceAd(FormatImgLink(KS.ReplaceInnerLink(Replace(Replace(Replace(Replace(PageContent,"{$","{§"),"{LB","{#LB"),"{SQL","{#SQL"),"{=","{#=")),NextUrl,TotalPage),GetNodeText("tid"))
case "getarticleaction"
echo "【发表评论】【告诉好友】【打印此文】【收藏此文】【关闭窗口】"
case "getarticleintro" echo GetNodeText("intro")
case "getarticleshorttitle" echo GetNodeText("title")
case "getarticleurl" echo KS.GetItemURL(ModelID,GetNodeText("tid"),ItemID,GetNodeText("fname"))
case "getarticlekeyword" echo Replace(GetNodeText("keywords"), "|", ",")
case "getarticleauthor" echo LFCls.ReplaceDBNull(GetNodeText("author"),"佚名")
case "getarticleinput" echo "" & GetNodeText("inputer") & ""
case "getarticleorigin" echo KS.GetOrigin(LFCls.ReplaceDBNull(GetNodeText("origin"),"本站原创"))
case "getarticleproperty"
If GetNodeText("recommend") = "1" Then echo "荐 "
If GetNodeText("popular") = "1" Then echo "热 "
If GetNodeText("strip")="1" Then echo "头 "
If GetNodeText("rolls") = "1" Then echo "滚 "
If GetNodeText("slide") = "1" Then echo "幻"
case "getarticledate" echo KS.DateFormat(GetNodeText("adddate"), 6)
case "getprevarticle" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), "<")
case "getnextarticle" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), ">")
case "getpictureaction" echo "【我来评论】【我要收藏】【关闭窗口】"
'================================文章模型结束=================================
'================================图片模型开始================================
case "getpicturename" echo GetNodeText("title")
case "showpictures" echo PageContent
case "getpictureintro" echo KS.ReplaceInnerLink(GetNodeText("picturecontent"))
case "getpictureurl" echo KS.GetItemURL(ModelID,GetNodeText("tid"),ItemID,GetNodeText("fname"))
case "getpicturekeyword" echo Replace(GetNodeText("keywords"), "|", ",")
case "getpictureauthor" echo LFCls.ReplaceDBNull(GetNodeText("author"),"佚名")
case "getpictureinput" echo "" & GetNodeText("inputer") & ""
case "getpicturesrc","getphotourl"
Dim Purl:Purl=GetNodeText("photourl")
If KS.IsNul(Purl) Then echo DomainStr &"images/nopic.gif" Else Echo purl
case "getpictureorigin" echo KS.GetOrigin(LFCls.ReplaceDBNull(GetNodeText("origin"),"本站原创"))
case "getpictureproperty"
If GetNodeText("recommend") = "1" Then Echo "荐 "
If GetNodeText("popular") = "1" Then echo "热 "
If GetNodeText("strip")="1" Then echo "头 "
If GetNodeText("rolls") = "1" Then echo "滚 "
If GetNodeText("slide") = "1" Then echo "幻"
case "getpicturevotescore" echo ""
case "getpicturevote" echo "投它一票"
case "getpicturedate" echo KS.DateFormat(GetNodeText("adddate"), 6)
case "getprevpicture" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), "<")
case "getnextpicture" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), ">")
'================================图片模型结束================================
'================================下载模型开始================================
case "getdowntitle" echo GetNodeText("title") & " " & GetNodeText("downversion")
case "getdownaction" echo "【我来评论】【我要收藏】【关闭窗口】"
case "getdownkeyword" echo Replace(GetNodeText("keywords"), "|", ",")
case "getdownurl" echo KS.GetItemURL(ModelID,GetNodeText("tid"),ItemID,GetNodeText("fname"))
case "getdownsystem" echo GetNodeText("downpt")
case "getdownauthor" echo LFCls.ReplaceDBNull(GetNodeText("author"),"佚名")
case "getdownorigin" echo KS.GetOrigin(LFCls.ReplaceDBNull(GetNodeText("origin"),"本站原创"))
case "getdownsize" echo GetNodeText("downsize")
case "getdowntype" echo GetNodeText("downlb")
case "getdownlanguage" echo GetNodeText("downyy")
case "getdownpower" echo GetNodeText("downsq")
case "getdownpoint" echo GetNodeText("readpoint")
case "getdowndecpass" echo GetNodeText("jymm")
case "getdownintro" echo KS.ReplaceInnerLink(GetNodeText("downcontent"))
case "getdownaddress"
Dim UrlArr, I,N,TotalNum, AUrl
UrlArr = Split(GetNodeText("downurls"), "|||")
TotalNum = UBound(UrlArr)
For I = 0 To TotalNum
N=N+1: AUrl = Split(UrlArr(I), "|")
If AUrl(0)=0 Then
echoln "" & AUrl(1) & ""
If I<>TotalNum Then echoln " "
Else
Dim RS_S:Set RS_S=Conn.Execute("Select DownloadName,IsDisp,DownloadPath,DownID,SelFont From KS_DownSer Where ParentID=" & AUrl(0))
If RS_S.Eof Then
If TotalNum=0 Then UrlStr="
暂不提供下载地址
"
Else
DO While Not RS_S.Eof
IF RS_S(1)=1 Then
echoln "" & RS_S(0) & ""
Else
echoln "" & RS_S(0) & ""
End If
RS_S.MoveNext
IF Not RS_S.Eof Or I<>TotalNum Then echoln " "
Loop
End If
RS_S.Close:Set RS_S=Nothing
End If
Next
case "getdownlink"
If Not (LCase(Node.SelectSingleNode("@ysdz").text) = "http://" Or Node.SelectSingleNode("@ysdz").text = "") Then echo "作者或开发商主页"
If Not (LCase(Node.SelectSingleNode("@zcdz").text) = "http://" Or Node.SelectSingleNode("@zcdz").text = "") Then echo " 注册地址"
case "getdownysdz"
If LCase(Node.SelectSingleNode("@ysdz").text) = "http://" Or Node.SelectSingleNode("@ysdz").text = "" Then
echo "无"
Else
echo "" & Node.SelectSingleNode("@ysdz").text & ""
End If
case "getdownzcdz"
If LCase(Node.SelectSingleNode("@zcdz").text) = "http://" Or Node.SelectSingleNode("@zcdz").text = "" Then
echo "无"
Else
echo "" & Node.SelectSingleNode("@zcdz").text & ""
End If
case "getdownproperty"
If GetNodeText("recommend") = "1" Then Echo "荐 "
If GetNodeText("popular") = "1" Then echo "热 "
If GetNodeText("strip")="1" Then echo "头 "
If GetNodeText("rolls") = "1" Then echo "滚 "
If GetNodeText("slide") = "1" Then echo "幻"
case "getdowndate" echo KS.DateFormat(GetNodeText("adddate"), 6)
case "getdowninput" echo "" & GetNodeText("inputer") & ""
case "getprevdown" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), "<")
case "getnextdown" echo LFCls.ReplacePrevNext(ModelID,ItemID, GetNodeText("tid"), ">")
'================================下载模型开始================================
case else
echo ShCls.run(sTemp)
If lcase(left(sTemp,3))="ks_" Then
echo GetNodeText(Lcase(sTemp)) '输出自定义字段
ElseIf lcase(left(sTemp,3))="fl_" Then
echo GetNodeText(Lcase(right(sTemp,len(sTemp)-3))) '输出任意字段
elseIf left(lcase(sTemp),3)="js_" then
Call JsCls.Run(sTemp,Templates)
End If
end select
'Parse = iPosBegin
Set MyNode=Nothing
End Function
'解释等号标签
Function ParseEqual(sTemplate, sTemp)
Dim MyNode,TagName,TagParam,Param,PosTag,I
PosTag = InStr(sTemp,"(")
If PosTag>0 Then
TagName = Mid(sTemp,1,PosTag-1)
TagParam = Replace(Replace(sTemp,")",""),TagName&"(","")
'response.write (sTemp & "=" & tagParam)
'response.end
Param = Split(TagParam,",")
select case Lcase(TagName)
case "getlogo" echo ""
case "getadvertise" echo ""
case "gettopuser" GetTopUser Param(0),Param(1)
case "getvote" echo GetVote(TagParam)
case "gettags" echo GetTags(Param(0),Param(1))
case "getuserdynamic" GetUserDynamic TagParam
case "getphoto" echo ""
case "getdownphoto" ,"getmoviephoto","getsupplyphoto"
Dim DownPhotoUrl:DownPhotoUrl=GetNodeText("photourl") : If DownPhotoUrl="" Or IsNull(DownPhotoUrl) Then DownPhotoUrl=DomainStr & "images/nopic.gif"
if Lcase(left(DownPhotoUrl,7))<>"http://" then DownPhotoUrl=KS.Setting(2) &DownPhotoUrl
echo ""
case "getmovieplaylist" '影视播放器
Dim PerLineNum: PerLineNum = Param(0)
Dim NaviPicStr: NaviPicStr = Param(1)
Dim PlayListStr,MovieNum,MovieUrlsArr:MovieUrlsArr=Split(GetNodeText("movieurls"),"|||")
MovieNum=Ubound(MovieUrlsArr)+1
If MovieNum=1 Then
echo " " & GetNodeText("title") & " "
Else
For I=0 To MovieNum-1
Dim Marr:Marr=Split(MovieUrlsArr(i),"|")
If I=0 Then
echo " " & Marr(0) & " "
Else
echo " " & Marr(0) & " "
End If
If Cint(I+1) Mod PerLineNum = 0 Then echo " "
Next
End If
case "getmoviedownlist" '影片下载
If GetNodeText("downtf")="0" Then
echo "---"
Else
PerLineNum = Param(0)
NaviPicStr = Param(1)
MovieUrlsArr=Split(GetNodeText("movieurls"),"|||")
MovieNum=Ubound(MovieUrlsArr)+1
If MovieNum=1 Then
echo " " & GetNodeText("title") & " "
Else
For I=0 To MovieNum-1
Marr=Split(MovieUrlsArr(I),"|")
If I=0 Then
echo " " & Marr(0) & " "
Else
echo " " & Marr(0) & " "
End If
If Cint(I+1) Mod PerLineNum = 0 Then echo " "
Next
End If
End If
case "getmoviepageplay" echo GetMoviePagePlay(Param)
case else
If left(lcase(TagName),3)="js_" then
Call JSCls.Equal(TagName,Param,Templates)
end if
end select
End If
End Function
'替换频道专用标签
Sub ParseChannelLabel(ByVal sTemp)
on error resume next
If FCls.RefreshFolderID="0" Or FCls.RefreshFolderID="" Then Exit Sub
Dim I,ClassBasicInfoArr,ClassDefineContentArr
ClassBasicInfoArr = Split(KS.C_C(FCls.RefreshFolderID,6),"||||")
ClassDefineContentArr= Split(KS.C_C(FCls.RefreshFolderID,7),"||||")
sTemp = Lcase(sTemp)
select case sTemp
case "getchannelid" echo Fcls.ChannelID
case "getchannelname" echo KS.C_S(FCls.ChannelID,1)
case "getitemname" echo KS.C_S(FCls.ChannelID,3)
case "getitemurl" echo KS.C_S(FCls.ChannelID,4)
case "getclassid" echo FCls.RefreshFolderID
case "getparentid" echo FCls.RefreshParentID
case "getparenturl" If FCls.RefreshParentID="0" Then echo KS.Setting(2) else echo KS.GetFolderPath(FCls.RefreshParentID)
case "getparentclassname"
if FCls.RefreshType="Content" Then
echo KS.C_C(KS.C_C(FCls.RefreshFolderID,13),1)
Else
echo KS.C_C(FCls.RefreshParentID,1)
End If
case "getclassname" echo KS.C_C(FCls.RefreshFolderID,1)
case "getclassurl" echo KS.GetFolderPath(FCls.RefreshFolderID)
end select
If IsArray(ClassBasicInfoArr) Then
select case sTemp
case "getclasspic" echo ""
case "getclassintro" echo ClassBasicInfoArr(1)
case "getclass_meta_keyword" echo ClassBasicInfoArr(2)
case "getclass_meta_description" echo ClassBasicInfoArr(3)
end select
End If
If IsArray(ClassDefineContentArr) Then
For I=1 To Ubound(ClassDefineContentArr)+1
if sTemp="getclassdefinecontent" & I then echo ClassDefineContentArr(I-1)
Next
End If
if err then err.clear
End Sub
'替换RSS标签
Sub ParseRssLabel(sTemp)
IF KS.Setting(83)=0 Then Exit Sub
Dim CurrentClassID:CurrentClassID=FCls.RefreshFolderID
Dim ChannelID:ChannelID=FCls.ChannelID
select case Lcase(sTemp)
case "rss"
select case Lcase(FCls.RefreshType)
case "index" echo GetRssLink("rss.asp")
case "folder" echo GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & "")
end select
case "rsselite"
select case Lcase(FCls.RefreshType)
case "index" echo GetRssLink("Rss.asp?Elite=1")
case "folder" echo GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & "&Elite=1")
end select
case "rsshot"
select case Lcase(FCls.RefreshType)
case "index" echo GetRssLink("Rss.asp?Hot=1")
case "folder" echo GetRssLink("Rss.asp?ChannelID=" & ChannelID & "&ClassID=" &CurrentClassID & "&Hot=1")
end select
end select
End Sub
'取得每个频道的RSS链接,结合ParseRssLabel调用
Function GetRssLink(LinkStr)
GetRssLink=""
End Function
'扫描并替换附件信息
Function ScanAnnex(sTemplate)
If Instr(sTemplate,"[UploadFiles]")=0 or Instr(sTemplate,"[/UploadFiles]")=0 Then ScanAnnex=ReplaceEmot(sTemplate) : Exit Function
Dim TempStr,iPosLast, iPosCur,iPosBegin
iPosLast = 1
Do While True
iPosCur = InStr(iPosLast, sTemplate, "[UploadFiles]")
If iPosCur>0 Then
TempStr=TempStr & Mid(sTemplate, iPosLast, iPosCur-iPosLast)
Dim iPosCur1, sToken, sTemp,FileInfoArr,FileSize,Ext,Title
iPosBegin=iPosCur+13
iPosCur1 = InStr(iPosBegin, sTemplate, "[/UploadFiles]")
sTemp = Mid(sTemplate,iPosBegin,iPosCur1-iPosBegin)
FileInfoArr = split(sTemp,",")
iPosBegin = iPosCur1+14
If Ubound(FileInfoArr)>=1 Then
FileSize=KS.ChkClng(FileInfoArr(1))
If FileSize<1 Then
FileSize=FormatNumber(FileSize,2,-1,0,-1) & " bytes"
ElseIf FileSize>1024*1024 Then
FileSize=FormatNumber(round(FileSize/1024/1024,2),2,-1,0,-1) & " MB"
Else
FileSize=FormatNumber(round(FileSize/1024,2),2,-1,0,-1) & " KB"
End If
End If
If Ubound(FileInfoArr)>=2 Then Ext=FileInfoArr(2) Else Ext="rar"
If Ubound(FileInfoArr)>=3 Then Title="点击下载文件:" & FileInfoArr(3) Else Title="点击下载该文件"
tempstr=tempstr & "
"
iPosLast=iPosBegin
Else
TempStr=TempStr &Mid(sTemplate, iPosLast)
Exit Do
End If
Loop
ScanAnnex=ReplaceEmot(TempStr)
End Function
'替换表情
Function ReplaceEmot(c)
Dim str:str=":)|:(|:D|:'(|:@|:o|:P|:$|;P|:L|:Q|:lol|:loveliness:|:funk:|:curse:|:dizzy:|:shutup:|:sleepy:|:hug:|:victory:|:time:|:kiss:|:handshake|:call:|55555|不是我|不要啊|亲一亲|加油|向前进|吓死你|呐喊|鸣哇|呵呵|呸|哈哈|哼|嗯|嘿嘿|困死了|天打雷劈|好闷啊|对不起|开心|很忙|抓狂|放电|无聊|汗一个|看我历害|脑残|飞吻|good|不妙啊|不是啦|交出来|亲亲|偷笑|哭|喜欢|嗯|坏笑|太好啦|好主意|好同志|悄悄走|我爱你|打你|晕菜|没良心"
Dim strArr:strArr=Split(str,"|")
Dim K,NS
For K=1 To 70
NS=Right("0" & K,2)
c=replace(c,"[em"&NS &"]","")
Next
ReplaceEmot=C
End Function
'*******************************************************************************************************
'函数名:KSLabelReplaceAll
'作 用:替换所有标签
'参 数:F_C 模板内容
'返回值:替换过的模板内容
'********************************************************************************************************
Public Function KSLabelReplaceAll(F_C)
F_C = ReplaceAllLabel(F_C)
F_C = ReplaceLableFlag(F_C) '替换函数标签
F_C = ReplaceGeneralLabelContent(F_C) '替换通用标签 如{$GetWebmaster}
F_C = ReplaceRA(F_C, "")
KSLabelReplaceAll=F_C
End Function
'*******************************************************************************************************
'函数名:LoadTemplate
'作 用:取出模板内容
'参 数:TemplateFname模板地址
'返回值:模板内容
'********************************************************************************************************
Function LoadTemplate(TemplateFname)
on error resume next
Dim FSO, FileObj, FileStreamObj
Set FSO = KS.InitialObject(KS.Setting(99))
TemplateFname=Replace(TemplateFname,"{@TemplateDir}",KS.Setting(3) & KS.Setting(90))
TemplateFname = Server.MapPath(Replace(TemplateFname, "//", "/"))
If FSO.FileExists(TemplateFname) = False Then
LoadTemplate = "模板不存在,请先绑定!"
Else
Set FileObj = FSO.GetFile(TemplateFname)
Set FileStreamObj = FileObj.OpenAsTextStream(1)
If Not FileStreamObj.AtEndOfStream Then
LoadTemplate = FileStreamObj.ReadAll
Else
LoadTemplate = "模板内容为空"
End If
End If
LoadTemplate = ReadTemplate(TemplateFname,"gb2312")
Set FSO = Nothing:Set FileObj = Nothing:Set FileStreamObj = Nothing
LoadTemplate=LoadTemplate & Published
End Function
function ReadTemplate(TempBody,CharSet)
dim str,stm
set stm=server.CreateObject("adodb.stream")
stm.Type=2
stm.mode=3
stm.charset=CharSet
stm.open
stm.loadfromfile TempBody
str=stm.readtext
stm.Close
set stm=nothing
ReadTemplate=str
end function
'**************************************************
'函数名:ReplaceLableFlag
'作 用:去除标签{$},并分组以将标签参数用","隔开
' 示例: km=ReplaceLableFlag("{$Test("par1","par2","par3")}")
' 结果 km=Test,Par1,Par2,Par3
'参 数: Content ----待替换内容
'返回值:返回用","隔开的字符串
'**************************************************
Function ReplaceLableFlag(Content)
Dim regEx, Matches, Match, TempStr
Set regEx = New RegExp
ReplaceLableFlag = Content
Set regEx = New RegExp
regEx.Pattern = "{Tag([\s\S]*?):(.+?)}([\s\S]*?){/Tag\1}"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(Content)
For Each Match In Matches
ReplaceLableFlag = Replace(ReplaceLableFlag,Match.Value,KSLabel.GetLabel(Match.Value))
Next
End Function
'扫描系统函数标签
Function ScanSysLabel(Content)
Dim iPosLast, iPosCur,Tstr
iPosLast = 1
Do While True
iPosCur = InStr(iPosLast, Content, "{LB_")
If iPosCur>0 Then
Tstr=tstr & Mid(Content, iPosLast, iPosCur-iPosLast)
iPosLast = ParseSysLabel(Content, iPosCur+4,Tstr)
Else
Tstr=tstr & Mid(Content, iPosLast)
Exit do
End If
Loop
ScanSysLabel=Tstr
End Function
Function ParseSysLabel(sTemplate, iPosBegin,Tstr)
Dim iPosCur, sToken, sTemp,MyNode
iPosCur = InStr(iPosBegin, sTemplate, "}")
sTemp = Mid(sTemplate,iPosBegin,iPosCur-iPosBegin)
iPosBegin = iPosCur+1
Set MyNode = Application(KS.SiteSN&"_labellist").documentElement.SelectSingleNode("labellist[@labelname='{LB_" & sTemp & "}']")
If Not MyNode Is Nothing Then Tstr=Tstr & MyNode.text
ParseSysLabel= iPosBegin
End Function
'*********************************************************************************************************
'函数名:ReplaceAllLabel
'作 用:将标签名称转换成对应标签内容
'参 数: Content需转换的内容
'*********************************************************************************************************
Function ReplaceAllLabel(Content)
dim Node
Call LoadLabelToCache() '加载标签
Content=ScanSysLabel(Content)
Call LoadJSFileToCache() '加载JS
For Each Node in Application(KS.SiteSN&"_jslist").documentElement.SelectNodes("jslist")
Content=Replace(Content,Node.selectSingleNode("@jsname").text,Node.text)
Next
If Lcase(Fcls.RefreshType)<>"content" Then Content=ReplaceSQLLabel(Content)
ReplaceAllLabel=Content
End Function
Function ReplaceSQLLabel(Content)
'替换自定义函数标签
Dim DCls:Set Dcls=New DIYCls
ReplaceSQLLabel=DCls.ReplaceUserFunctionLabel(Content)
Set DCls=nothing
End Function
'加载数据库的所有标签到缓存
Sub LoadLabelToCache()
If Not IsObject(Application(KS.SiteSN&"_labellist")) Then
Set Application(KS.SiteSN&"_labellist")=KS.InitialObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
Application(KS.SiteSN&"_labellist").appendChild(Application(KS.SiteSN&"_labellist").createElement("xml"))
Dim i,SQL,Node
Dim RS:Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open "Select ID,LabelType,LabelName,LabelContent from KS_Label Where LabelType<>5", Conn, 1, 1
If Not RS.Eof Then SQL=RS.GetRows(-1)
RS.Close:Set RS = Nothing
If IsArray(SQL) Then
for i=0 to Ubound(SQL,2)
Set Node=Application(KS.SiteSN&"_labellist").documentElement.appendChild(Application(KS.SiteSN&"_labellist").createNode(1,"labellist",""))
Node.attributes.setNamedItem(Application(KS.SiteSN&"_labellist").createNode(2,"labelname","")).text=SQL(2,I)
Node.attributes.setNamedItem(Application(KS.SiteSN&"_labellist").createNode(2,"labelid","")).text=SQL(0,I)
If SQL(1,I) = 1 Then
Node.text=ReplaceFreeLabel(SQL(3,I))
Else
Node.text=Replace(SQL(3,I),"labelid=""0""","labelid=""" & SQL(0,I) & """")
End IF
next
End If
End if
End Sub
'加载数据库的所有JS到缓存
Sub LoadJSFileToCache()
If Not IsObject(Application(KS.SiteSN&"_jslist")) Then
Set Application(KS.SiteSN&"_jslist")=KS.InitialObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
Application(KS.SiteSN&"_jslist").appendChild( Application(KS.SiteSN&"_jslist").createElement("xml"))
Dim i,SQL,Node
Dim RS:Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open "Select JSID,JSName,JSFileName from KS_JSFile", Conn, 1, 1
If Not RS.Eof Then SQL=RS.GetRows(-1)
RS.Close:Set RS = Nothing
If IsArray(SQL) Then
for i=0 to Ubound(SQL,2)
Set Node=Application(KS.SiteSN&"_jslist").documentElement.appendChild(Application(KS.SiteSN&"_jslist").createNode(1,"jslist",""))
Node.attributes.setNamedItem(Application(KS.SiteSN&"_jslist").createNode(2,"jsname","")).text=SQL(1,I)
Node.text=""
next
End If
End if
End Sub
'替换自由标签为内容,仅替换一级
Function ReplaceFreeLabel(sTrC)
dim node
If not IsObject(Application(KS.SiteSN&"_ReplaceFreeLabel")) then
Dim RS:Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open "Select LabelName,LabelContent,ID from KS_Label", Conn, 1, 1
if Not RS.eof then
'KS.Value=RS.GetString(,,"^||^","^%%%^","")
Set Application(KS.SiteSN&"_ReplaceFreeLabel")=KS.ArrayToXml(RS.GetRows(-1),rs,"row","")
end if
RS.Close:Set RS = Nothing
End if
For Each Node In Application(KS.SiteSN&"_ReplaceFreeLabel").documentElement.SelectNodes("row")
sTrC = Replace(sTrC,trim(Node.SelectSingleNode("@labelname").text),Replace(Node.SelectSingleNode("@labelcontent").text,")}","," & Node.SelectSingleNode("@id").text &")}"))
next
'ReplaceFreeLabel = ReplaceGeneralLabelContent(sTrC)
ReplaceFreeLabel = ScanSysLabel(sTrC)
End Function
'*********************************************************************************************************
'函数名:FSOSaveFile
'作 用:生成文件
'参 数: Content内容,路径 注意虚拟目录
'*********************************************************************************************************
Sub FSOSaveFile(Content, FileName)
dim stm:set stm=server.CreateObject("adodb.stream")
stm.Type=2 '以文本模式读取
stm.mode=3
stm.charset="gb2312"
stm.open
stm.WriteText content
stm.SaveToFile server.MapPath(FileName),2
stm.flush
stm.Close
set stm=nothing
End Sub
'*********************************************************************************************************
'函数名:RefreshJS
'作 用:发布JS
'参 数:JSName JS名称
'*********************************************************************************************************
Sub RefreshJS(JSName)
Dim JSRS, SqlStr, JSContent
Set JSRS = Server.CreateObject("ADODB.Recordset")
SqlStr = "Select * From KS_JSFile Where JSName='" & Trim(JSName) & "'"
JSRS.Open SqlStr, Conn, 1, 1
If JSRS.EOF And JSRS.BOF Then
JSRS.Close:Set JSRS = Nothing:Exit Sub
End If
Dim JSConfig, JSFileName, SaveFilePath, JSDir, JSType
JSFileName = Trim(JSRS("JSFileName"))
JSDir = Trim(KS.Setting(93))
JSType = Trim(JSRS("JSType"))
If Left(JSDir, 1) = "/" Or Left(JSDir, 1) = "\" Then JSDir = Right(JSDir, Len(JSDir) - 1)
SaveFilePath = KS.Setting(3) & JSDir
Call KS.CreateListFolder(SaveFilePath)
JSConfig = Trim(JSRS("JSConfig"))
If JSType = "0" Then
JSContent=Replace(Replace(Replace(Replace(KSLabel.GetLabel(JSConfig), Chr(13)& Chr(10), ""),"'","\'"),"""","\"""),vbcrlf,"")
JSContent=Replace(JSContent,Chr(13) ,"")
JSContent = "document.write('" & JSContent & "');"
Else
Dim FreeType
FreeType = Left(JSConfig, InStr(JSConfig, ",") - 1) '取出自由JS的类型
JSConfig = Replace(JSConfig, FreeType & ",", "")
Select Case FreeType '根据函数做相应的操作
Case "GetExtJS" '扩展JS
JSConfig = Replace(JSConfig, "'", """")
JSConfig = ReplaceLableFlag(ReplaceAllLabel(JSConfig))
JSConfig = ReplaceGeneralLabelContent(JSConfig)
JSConfig = Replace(Replace(Replace(JSConfig, Published, ""),"'","\'"),"""","\""")
JSContent = ReplaceJsBr(JSConfig)
Case "GetWordJS"
JSConfig = Replace(Trim(JSConfig), """", "") '替换原参数的双引号为空
JSContent = RefreshWordJS(Trim(JSRS("JSID")), JSConfig) '替换文字JS
Case Else
JSContent = ""
End Select
End If
Call FSOSaveFile(JSContent, SaveFilePath & JSFileName)
JSRS.Close:Set JSRS = Nothing
End Sub
Function ReplaceJsBr(Content)
Dim i
Dim JsArr:JSArr=Split(Content,Chr(13) & Chr(10))
For I=0 To Ubound(JsArr)
ReplaceJsBr=ReplaceJsBr & "document.writeln('" & JsArr(I) &"')" & vbcrlf
Next
End Function
'*********************************************************************************************************
'函数名:RefreshWordJS
'作 用:发布文字JS
'参 数:JSID JSID,JSConfig JS参数
'*********************************************************************************************************
Function RefreshWordJS(JSID, JSConfig)
Dim JSConfigArr:JSConfigArr = Split(JSConfig, ",")
If UBound(JSConfigArr) = 17 Then
RefreshWordJS = KSLabel.RefreshCss(JSID, UCase(JSConfigArr(0)), JSConfigArr(1), JSConfigArr(2), JSConfigArr(3), JSConfigArr(4), JSConfigArr(5), JSConfigArr(6), JSConfigArr(7), JSConfigArr(8), JSConfigArr(9), JSConfigArr(10), JSConfigArr(11), JSConfigArr(12), JSConfigArr(13), JSConfigArr(14), JSConfigArr(15), JSConfigArr(16), JSConfigArr(17))
RefreshWordJS = Replace(RefreshWordJS, "'", """")
RefreshWordJS = "document.write('" & RefreshWordJS & "');"
Else
RefreshWordJS = "document.write('标签参数溢出!');"
End If
End Function
'=================================以下为相关栏目,内容页,频道首页等的刷新函数=====================================
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'函数名:RefreshContent
'作 用:刷新内容页面
'参 数: 无
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function RefreshContent()
Dim TFileContent, F_C, FilePath, FilePathAndName, FilePathAndNameTemp, sFname,Fname, FExt, TempFileContent, Content, ContentArr, I, N, CurrPage, PageStr, Flag
Dim TemplateID
TID = Trim(Node.SelectSingleNode("@tid").text)
Call FCls.SetContentInfo(ModelID,Tid,ItemID,Node.SelectSingleNode("@title").text)
If ModelID=8 Then
TemplateID = KS.C_C(Tid,5)
Else
TemplateID = Node.SelectSingleNode("@templateid").text
End If
TempFileContent = LoadTemplate(TemplateID)
TempFileContent = ReplaceAllLabel(TempFileContent)
If InStr(TempFileContent, "{Tag:GetRelativeList") <> 0 Then TempFileContent = Replace(TempFileContent, "{Tag:GetRelativeList", "{UnTag:GetRelativeList"):Flag = True Else Flag = False
If Flag = True Then
TFileContent = ReplaceLableFlag(TempFileContent)
ElseIf (TemplateID <> FCls.RefreshTemplateID) Or (Tid <> FCls.RefreshCurrTid) Or FCls.RefreshTempFileContent = "" Then
FCls.RefreshCurrTid = Tid
FCls.RefreshTemplateID = TemplateID
FCls.RefreshTempFileContent = ReplaceLableFlag(TempFileContent) '替换函数标签
TFileContent = FCls.RefreshTempFileContent
Else
TFileContent = FCls.RefreshTempFileContent
End If
on error resume next
sFname = Trim(Node.SelectSingleNode("@fname").text)
FExt = Mid(sFname, InStrRev(sFname, ".")) '分离出扩展名
Fname = Replace(sFname, FExt, "") '分离出文件名 如 2005/9-10/1254ddd
FilePathAndNameTemp =KS.LoadFsoContentRule(ModelID,Tid)
Dim ShowUrl:ShowUrl=KS.LoadInfoUrl(ModelID,Tid,"")
FilePathAndName = FilePathAndNameTemp & sFname
FilePath = Replace(FilePathAndName, Mid(FilePathAndName, InStrRev(FilePathAndName, "/")), "")
Call KS.CreateListFolder(FilePath)
'判断是不是转向链接
If KS.C_S(ModelID,6)=1 Then
if node.SelectSingleNode("@changes").text="1" then
Templates=""
echoln ""
Call FSOSaveFile(Templates, FilePathAndName)
Exit Function
end If
End If
'判断是不是收费信息
IF KS.C_S(ModelID,6)=1 or KS.C_S(ModelID,6)=2 or KS.C_S(ModelID,6)=4 Then
If Node.SelectSingleNode("@readpoint").text>0 or Node.SelectSingleNode("@infopurview").text="2" Or (Node.SelectSingleNode("@infopurview").text=0 And (KS.C_C(Tid,3)=1 Or KS.C_C(Tid,3)=2)) Then
Templates=""
echoln ""
Call FSOSaveFile(Templates, FilePathAndName)
Exit Function
End If
End If
Dim StartPage,K
Select Case Cint(KS.C_S(ModelID,6))
Case 1 '文章模型
Content = Node.SelectSingleNode("@articlecontent").text
If IsNull(Content) or Content="" Then Content = " "
ContentArr = Split(Content, "[NextPage]")
TotalPage = UBound(ContentArr) + 1
For I = 0 To UBound(ContentArr)
CurrPage = I + 1
GetPrevNextUrl TotalPage,CurrPage,ShowUrl,sFname,Fname,FExt,Tid '得到上一页及下一页URL
PageStr=GetContentPage(TotalPage,CurrPage,ShowUrl,sFname,Fname,FExt) '取得分页
F_C = TFileContent
If CurrPage <> 1 Then FilePathAndName = FilePathAndNameTemp & Fname & "_" & CurrPage & FExt
Dim PageTitleArr,PageTitle
PageTitle=Node.SelectSingleNode("@pagetitle").text
If Not KS.IsNul(PageTitle) Then
PageTitleArr=Split(PageTitle,"§")
If CurrPage-1<=Ubound(PageTitleArr) Then
F_C=Replace(F_C,"{$GetArticleTitle}",PageTitleArr(CurrPage-1))
End If
ElseIF Currpage>1 Then
F_C=Replace(F_C,"{$GetArticleTitle}",GetNodeText("title") & "(" & currpage & ")")
End IF
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
PageContent="
" & ContentArr(I) & "
" & PageStr
Templates = ""
Scan F_C
F_C = Templates
F_C = Replace(Replace(F_C,"[KS_Charge]",""),"[/KS_Charge]","")
If Instr(F_C,"[KS_ShowIntro]")<>0 Then
If CurrPage=1 Then
F_C=Replace(Replace(F_C,"[KS_ShowIntro]",""),"[/KS_ShowIntro]","")
Else
F_C=Replace(F_C,KS.CutFixContent(F_C, "[KS_ShowIntro]", "[/KS_ShowIntro]", 1),"")
End If
End If
F_C = ReplaceGeneralLabelContent(F_C)
F_C = ReplaceRA(F_C, Trim(KS.C_C(Tid,4)))
F_C = Replace(Replace(Replace(Replace(F_C,"{§","{$"),"{#LB","{LB"),"{#SQL","{SQL"),"{#=","{=")
Call FSOSaveFile(F_C, FilePathAndName)
Next
case 2 '图片模型
Content=Node.SelectSingleNode("@picurls").text
If IsNull(Content) Then Content = ""
ContentArr = Split(Content, "|||") : TotalPage = UBound(ContentArr) + 1
Dim ShowStyle,PageNum,Tp
ShowStyle=KS.ChkClng(Node.SelectSingleNode("@showstyle").text) : If ShowStyle=0 Then ShowStyle=1
PageNum=KS.ChkClng(Node.SelectSingleNode("@pagenum").text) : If PageNum=0 Then PageNum=10
If (ShowStyle=1 or ShowStyle=2 Or ShowStyle=4) And TotalPage<=1 Then ShowStyle=3
Select Case ShowStyle
case 1
Tp=LFCls.GetConfigFromXML("picturelabel","/labeltemplate/label","style1")
Dim ThumbList,DefaultImageSrc,DefaultImageIntro,r,Tpage
For I = 0 To TotalPage - 1
CurrPage = I + 1
GetPrevNextUrl TotalPage,CurrPage,ShowUrl,sFname,Fname,FExt,Tid '得到上一页及下一页URL
ThumbList=""
For n=1 To TotalPage
If N=1 Then
If CurrPage = N Then
ThumbList=ThumbList &"
"
Else
ThumbList=ThumbList &"
"
End If
Else
If CurrPage = N Then
ThumbList=ThumbList &"
"
Else
ThumbList=ThumbList &"
"
End If
End If
Next
DefaultImageSrc=Split(ContentArr(CurrPage-1), "|")(1)
DefaultImageIntro=Split(ContentArr(CurrPage-1), "|")(0)
If CurrPage <> 1 Then FilePathAndName = FilePathAndNameTemp & Fname & "_" & CurrPage & FExt
F_C = TFileContent
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
Dim PicSrc :PicSrc=Split(ContentArr(I), "|")(1)
If (Lcase(Left(PicSrc,4))<>"http") Then PicSrc=KS.Setting(2) & PicSrc
PageContent=Replace(Tp,"{$PrevUrl}",PrevUrl)
PageContent=Replace(PageContent,"{$NextUrl}",NextUrl)
PageContent=Replace(PageContent,"{$CurrPage}",CurrPage)
PageContent=Replace(PageContent,"{$TotalPage}",TotalPage)
PageContent=Replace(PageContent,"{$ShowThumbList}",ThumbList)
PageContent=Replace(PageContent,"{$DefaultImageSrc}",DefaultImageSrc)
PageContent=Replace(PageContent,"{$DefaultImageIntro}",DefaultImageIntro)
If TotalPage>1 Then F_C=Replace(F_C,"{$GetPictureName}",GetNodeText("title") & "(" & currpage & ")")
Templates = "" : Scan F_C
F_C = Templates
F_C = ReplaceGeneralLabelContent(F_C)
F_C = ReplaceRA(F_C, Trim(KS.C_C(Tid,4)))
Call FSOSaveFile(F_C, FilePathAndName)
Next
case 4 '不分页
Dim BigImgSrc,IntroList
For n=1 To TotalPage
IntroList=IntroList & Split(ContentArr(n-1),"|")(0) &"|"
BigImgSrc=BigImgSrc & Split(ContentArr(n-1),"|")(1) &"|"
If CurrPage = N Then
ThumbList=ThumbList &"
"
Else
ThumbList=ThumbList &"
"
End If
Next
DefaultImageSrc=Split(ContentArr(0), "|")(1)
DefaultImageIntro=Split(ContentArr(0), "|")(0)
Tp=LFCls.GetConfigFromXML("picturelabel","/labeltemplate/label","style4")
Tp=Replace(Tp,"{$TotalPage}",TotalPage)
Tp=Replace(Tp,"{$ImgArr}",BigImgSrc)
Tp=Replace(Tp,"{$IntroArr}",Replace(Replace(IntroList,"'","\'"),chr(10)," "))
Tp=Replace(Tp,"{$ShowThumbList}",ThumbList)
Tp=Replace(Tp,"{$DefaultImageSrc}",DefaultImageSrc)
Tp=Replace(Tp,"{$DefaultImageIntro}",DefaultImageIntro)
PageContent=Tp
F_C = TFileContent
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
Templates = "" : Scan F_C
F_C = Templates
F_C = ReplaceGeneralLabelContent(F_C)
F_C = ReplaceRA(F_C, Trim(KS.C_C(Tid,4)))
Call FSOSaveFile(F_C, FilePathAndName)
case 2
Tp=LFCls.GetConfigFromXML("picturelabel","/labeltemplate/label","style2")
if ((ubound(ContentArr)+1) mod pagenum)=0 then
Tpage=(ubound(ContentArr)+1)\pagenum
else
Tpage=(ubound(ContentArr)+1)\pagenum + 1
end if
For I = 0 To Tpage - 1
CurrPage = I + 1 : ThumbList=""
if CurrPage<=1 then n=0 else n=pagenum*(CurrPage-1)
For r=1 to pagenum
if n<=ubound(ContentArr) Then
ThumbList=ThumbList&"
"
else
exit for
end if
n=n+1
Next
If CurrPage <> 1 Then FilePathAndName = FilePathAndNameTemp & Fname & "_" & CurrPage & FExt
F_C = TFileContent
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
PageContent=Replace(Tp,"{$ShowGroupList}",ThumbList)
If Tpage>1 Then
F_C=Replace(F_C,"{$GetPictureName}",GetNodeText("title") & "(" & currpage & ")")
GetPrevNextUrl Tpage,CurrPage,ShowUrl,sFname,Fname,FExt,Tid '得到上一页及下一页URL
PageContent=Replace(PageContent,"{$ShowPage}",GetContentPage(Tpage,CurrPage,ShowUrl,sFname,Fname,FExt))
End If
Templates = "" : Scan F_C
F_C = Templates
F_C = ReplaceGeneralLabelContent(F_C)
F_C = ReplaceRA(F_C, Trim(KS.C_C(Tid,4)))
Call FSOSaveFile(F_C, FilePathAndName)
Next
case 3
Tp=LFCls.GetConfigFromXML("picturelabel","/labeltemplate/label","style3")
if ((ubound(ContentArr)+1) mod pagenum)=0 then
Tpage=(ubound(ContentArr)+1)\pagenum
else
Tpage=(ubound(ContentArr)+1)\pagenum + 1
end if
For I = 0 To Tpage - 1
CurrPage = I + 1 : ThumbList=""
if CurrPage<=1 then n=0 else n=pagenum*(CurrPage-1)
For r=1 to pagenum
if n<=ubound(ContentArr) Then ThumbList=ThumbList & "" & Split(ContentArr(n), "|")(0) & "" Else Exit For
n=n+1
Next
If CurrPage <> 1 Then FilePathAndName = FilePathAndNameTemp & Fname & "_" & CurrPage & FExt
F_C = TFileContent
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
PageContent=Replace(Tp,"{$ShowImgList}",ThumbList)
If Tpage>1 Then
F_C=Replace(F_C,"{$GetPictureName}",GetNodeText("title") & "(" & currpage & ")")
GetPrevNextUrl Tpage,CurrPage,ShowUrl,sFname,Fname,FExt,Tid '得到上一页及下一页URL
PageContent=Replace(PageContent,"{$ShowPage}",GetContentPage(Tpage,CurrPage,ShowUrl,sFname,Fname,FExt))
End If
Templates = "" : Scan F_C
F_C = Templates
F_C = ReplaceGeneralLabelContent(F_C)
F_C = ReplaceRA(F_C, Trim(KS.C_C(Tid,4)))
Call FSOSaveFile(F_C, FilePathAndName)
Next
End Select
case Else
F_C = TFileContent
If InStr(F_C, "{UnTag:GetRelativeList") <> 0 Then F_C = ReplaceLableFlag(Replace(F_C, "{UnTag:GetRelativeList", "{Tag:GetRelativeList"))
Templates = ""
'供求系统替换权限标签
If Fcls.ChannelID=8 And Instr(F_C,"[KS_Charge]")<>0 Then
Dim ChargeContent:ChargeContent=KS.CutFixContent(F_C, "[KS_Charge]", "[/KS_Charge]", 1)
F_C=Replace(F_C,ChargeContent,LFCls.GetConfigFromXML("supply","/labeltemplate/label","divajax"))
End If
Scan F_C
F_C = Templates
F_C = ReplaceRA(F_C, Trim(KS.C_C(TID,5))) '如果采用根相对路径,则替换绝对路径为根相对路径
Call FSOSaveFile(F_C, FilePathAndName)
end select
End Function
Sub GetPrevNextUrl(TotalPage,CurrPage,ShowUrl,sFname,Fname,FExt,Tid)
If TotalPage > 1 Then
If CurrPage=1 Then
NextUrl = ShowUrl & Fname & "_" & (CurrPage + 1) & FExt : PrevUrl="#"
ElseIf CurrPage = 2 And CurrPage <> TotalPage Then '对于最后一页刚好是第二页的要做特殊处理
NextUrl = ShowUrl & Fname & "_" & (CurrPage + 1) & FExt : PrevUrl = ShowUrl & sFname
ElseIf CurrPage = 2 And CurrPage = TotalPage Then
NextUrl=KS.GetFolderPath(Tid): PrevUrl = ShowUrl & sFname
ElseIf CurrPage = TotalPage Then
NextUrl=KS.GetFolderPath(Tid): PrevUrl = ShowUrl & Fname & "_" & (CurrPage - 1) & FExt
Else
NextUrl = ShowUrl & Fname & "_" & (CurrPage + 1) & FExt : PrevUrl = ShowUrl & Fname & "_" & (CurrPage - 1) & FExt
End If
Else
NextUrl=KS.GetFolderPath(Tid):PrevUrl="#"
End If
End Sub
Function GetContentPage(TotalPage,CurrPage,ShowUrl,sFname,Fname,FExt)
If TotalPage<=1 Then Exit Function
Dim PageStr,StartPage,K,N
PageStr = "
"
If CurrPage > 1 And PrevUrl<>"#" Then PageStr = PageStr & "上一页 "
startpage=1:k=0: if (CurrPage>=10) then startpage=(CurrPage\10-1)*10+CurrPage mod 10+2
For N = startpage To TotalPage
If CurrPage = N Then
PageStr = PageStr & ("" & N & " ")
Else
If N=1 Then
PageStr = PageStr & ("" & N & " ")
Else
PageStr = PageStr & ("" & N & " ")
End If
End If
K=K+1 : If K>=10 Then Exit For
Next
If CurrPage<>TotalPage Then PageStr = PageStr & "下一页"
PageStr = PageStr & "
"
GetContentPage=PageStr
End Function
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'函数名:RefreshFolder
'作 用:刷新栏目页面
'参 数:RS Recordset数据集
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function RefreshFolder(ChannelID,RS)
Dim F_C, FolderDir, FilePath, Index
Call FCls.SetClassInfo(RS("ChannelID"),RS("ID"),RS("TN"))
F_C = LoadTemplate(RS("FolderTemplateID"))
F_C = ReplaceAllLabel(F_C)
F_C = ReplaceLableFlag(F_C) '替换函数标签
F_C = ReplaceGeneralLabelContent(F_C) '替换网站通用标签
If KS.C_S(ChannelID,44)="1" Or (KS.C_S(ChannelID,44)="3" And Trim(RS("TN")) = "0") Then
Index = RS("FolderFsoIndex")
ElseIf KS.C_S(ChannelID,44)="4" Then
Index=KS.C_S(ChannelID,45) &Mid(Trim(RS("FolderFsoIndex")), InStrRev(Trim(RS("FolderFsoIndex")), ".")) '分离出扩展名
Else
Index=KS.C_S(ChannelID,45) & "_" & rs("classid")&Mid(Trim(RS("FolderFsoIndex")), InStrRev(Trim(RS("FolderFsoIndex")), ".")) '分离出扩展名
End If
If RS("ClassType")<>"3" Then
'If RS("TN")="0" Then
' Index=Split(RS("Folder"),"/")(0) & "/" & RS("FolderFsoIndex")
'ELSE
Index=Replace(Index,"{$TopClassEname}",Split(RS("Folder"),"/")(0))
Index=Replace(Index,"{$ClassEname}",Split(RS("Folder"),"/")(ubound(split(RS("Folder"),"/"))-1))
Index=Replace(Index,"{$ClassID}",RS("ClassID"))
Index=Replace(Index,"{$BigClassID}",RS("ID"))
'End If
End If
FolderDir = KS.C_S(ChannelID,8)
If Left(FolderDir, 1) = "/" Or Left(FolderDir, 1) = "\" Then FolderDir = Right(FolderDir, Len(FolderDir) - 1)
If KS.C_S(ChannelID,44)="1" Or RS("ClassType")="3" Then
FilePath = KS.Setting(3) & FolderDir & RS("Folder")
ElseIf KS.C_S(ChannelID,44)="2" Or KS.C_S(ChannelID,44)="4" Then
FilePath = KS.Setting(3) & FolderDir
Else
FilePath = KS.Setting(3) & FolderDir & Split(RS("Folder"),"/")(0) & "/"
End If
If RS("ClassType")="3" Then
Dim FsoName:FsoName = Mid(FilePath, InStrRev(FilePath, "/")) '分离出扩展名
Call KS.CreateListFolder(Replace(FilePath,FsoName,""))
Else
Dim FsoFolder:FsoFolder=FilePath
If Instr(Index,"/")<>0 Then
FsoFolder=FsoFolder & Replace(Trim(Index), Mid(Trim(Index), InStrRev(Trim(Index), "/")), "")
End If
Call KS.CreateListFolder(FsoFolder)
End If
If (FCls.PageList <> "") Then
Call GetPageStr(FCls.PageList, "", Index, F_C, FilePath, Trim(RS("FolderDomain")))
FCls.PageList=""
Else
F_C = Replace(F_C, "{PageListStr}", "")
F_C = ReplaceRA(F_C, Trim(RS("FolderDomain")))
If RS("ClassType")="3" Then Index=""
Call FSOSaveFile(F_C, FilePath & Index)
End If
End Function
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'函数名:RefreshSpecials
'作 用:刷新专题页面
'参 数:RS Recordset数据集
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function RefreshSpecials(RS)
Dim F_C, SpecialDir, FilePath,Index,TempStr
'设置刷新类型,以取得当前导航位置
Call FCls.SetSpecialInfo(RS("ClassID"),RS("SpecialID"))
'读出专题页对应的模板
F_C = LoadTemplate(RS("TemplateID"))
F_C = ReplaceSpecialContent(F_C,RS)
F_C = KSLabelReplaceAll(F_C)
Index = Trim(RS("FsoSpecialIndex"))
SpecialDir = KS.Setting(95)
If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
FilePath = KS.Setting(3) & SpecialDir & RS("SpecialEName") & "/"
Call KS.CreateListFolder(FilePath)
F_C = ReplaceLableFlag(F_C) '替换函数标签
If (FCls.PageList <> "") Then
Call GetPageStr(FCls.PageList, Trim(DomainStr & SpecialDir & RS("SpecialEname") & "/"), Index, F_C, FilePath, "")
FCls.PageList = ""
Else
F_C = Replace(F_C, "{PageListStr}", "")
Call FSOSaveFile(F_C, FilePath & Index)
End If
End Function
Function ReplaceSpecialContent(F_C,RS)
F_C=Replace(F_C,"{$GetSpecialName}",RS("SpecialName"))
If Not Isnull(RS("PhotoUrl")) And RS("PhotoUrl")<>"" Then
F_C=Replace(F_C,"{$GetSpecialPic}","")
Else
F_C=Replace(F_C,"{$GetSpecialPic}","")
End If
F_C=Replace(F_C,"{$GetSpecialNote}",RS("SpecialNote"))
F_C=Replace(F_C,"{$GetSpecialDate}",RS("SpecialAddDate"))
F_C=Replace(F_C,"{$GetSpecialMetaKey}",RS("MetaKey"))
F_C=Replace(F_C,"{$GetSpecialMetaDescript}",RS("MetaDescript"))
ReplaceSpecialContent=ReplaceSpecialClass(F_C)
End Function
Function ReplaceSpecialClass(F_C)
If FCls.RefreshType="Special" Or FCls.RefreshType="ChannelSpecial" Then
F_C=Replace(F_C,"{$GetSpecialClassName}",KS.GetSpecialClass(FCls.RefreshFolderID,"classname"))
F_C=Replace(F_C,"{$GetSpecialClassURL}",KS.GetFolderSpecialPath(FCls.RefreshFolderID, True))
End If
ReplaceSpecialClass=F_C
End Function
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'函数名:RefreshSpecialClass
'作 用:刷新频道专题汇总页
'参 数:RS Recordset数据集
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function RefreshSpecialClass(RS)
Dim F_C, SpecialDir, Index, FilePath
FCls.RefreshType = "ChannelSpecial"
FCls.RefreshFolderID = RS("ClassID")
FCls.ItemUnit="个"
If RS("TemplateID")="" Then
RefreshSpecialClass="请先绑定专题分类模板!":exit function
Else
F_C = LoadTemplate(RS("TemplateID"))
End If
F_C = ReplaceSpecialClass(F_C)
F_C = KSLabelReplaceAll(F_C)
SpecialDir = KS.Setting(95)
If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
Index = RS("FsoIndex")
FilePath = KS.Setting(3) & SpecialDir & RS("ClassEname") & "/"
Call KS.CreateListFolder(FilePath)
If (FCls.PageList <> "") Then
Call GetPageStr(FCls.PageList, Trim(DomainStr & SpecialDir & RS("ClassEname") & "/"), Index, F_C, FilePath, "")
FCls.PageList=""
Else
F_C = ReplaceRA(F_C, "")
Call FSOSaveFile(F_C, FilePath & Index)
End If
End Function
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'函数名:RefreshCommonPage
'作 用:刷新通用页面
'参 数:RS Recordset数据集
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function RefreshCommonPage(ByVal FileName,FsoFileName)
Dim F_C, CommonDir, FilePath
F_C = LoadTemplate(FileName)
F_C = KSLabelReplaceAll(F_C)
F_C = Replace(Replace(F_C,"{$InfoID}","0"),"{$GetClassID}","0")
'如果采用根相对路径,则替换绝对路径为根相对路径
F_C = ReplaceRA(F_C, "")
CommonDir = Replace(KS.Setting(94), "\", "")
If Left(CommonDir, 1) = "/" Then CommonDir = Right(CommonDir, Len(CommonDir) - 1)
'FilePath = KS.Setting(3) & CommonDir
FilePath=Replace(FsoFileName,Split(FsoFileName,"/")(Ubound(Split(FsoFileName,"/"))),"")
Call KS.CreateListFolder(KS.Setting(3) & CommonDir & FilePath)
Call FSOSaveFile(F_C, KS.Setting(3) & CommonDir & FsoFileName)
End Function
'*********************************************************************************************************
'函数名:ReplaceRA
'作 用:自动判断系统是否用相对路径或绝对路径并转换
'参 数:FileContent原文件,FolderDomain 是否有绑定二级域名
'*********************************************************************************************************
Function ReplaceRA(F_C, FolderDomain)
if instr(FCls.RefreshType,"guest")<>0 then ReplaceRA=F_C : exit function
If Lcase(Fcls.RefreshType)="content" Then F_C=ReplaceSQLLabel(F_C)
If CStr(KS.Setting(97)) = "0" Then
If FolderDomain <> "" Then
F_C = Replace(F_C, FolderDomain, "/")
Else
If Trim(KS.Setting(3)) = "/" Then
F_C = Replace(F_C, DomainStr, "/")
Else
F_C = Replace(F_C, Replace(DomainStr, Trim(KS.Setting(3)), ""), "")
End If
End If
End If
F_C=Replace(F_C,"{#GetFullDomain}",KS.Setting(2))
F_C=ScanAnnex(F_C)
ReplaceRA = F_C
End Function
'*********************************************************************************************************
'函数名:GetPageStr
'作 用:取得分页的通用函数
'参 数:PageContent--分页内容,LinkUrl--链接地址,Index-首页名称
' F_C--待保存的文件内容,FilePath---待保存路径,SecondDomain --二级域名
'*********************************************************************************************************
Sub GetPageStr(PageContent, LinkUrl, Index, F_C, FilePath, SecondDomain)
Dim PageStr, FileStr, I, PageContentArr,LoopEnd,TotalPage,Fname,FExt ,LinkUrlFname
FExt = Mid(Trim(Index), InStrRev(Trim(Index), ".")) '分离出扩展名
Fname = Replace(Trim(Index), FExt, "") '分离出文件名
LinkUrlFname = LinkUrl & Fname
Dim HomeLink:HomeLink=LinkUrl & Index
If Instr(HomeLink,"/")<>0 Then
HomeLink = Mid(HomeLink, InStrRev(HomeLink, "/")+1) '分离出文件名
End If
If Instr(LinkUrlFname,"/")<>0 Then
LinkUrlFname = Mid(LinkUrlFname, InStrRev(LinkUrlFname, "/")+1) '分离出文件名
End If
PageContentArr = Split(PageContent, "{KS:PageList}")
TotalPage = FCls.TotalPage
If KS.ChkClng(FCls.FsoListNum)<>0 and KS.ChkClng(FCls.FsoListNum)TotalPage Then
PageStr = "首页 上一页 下一页尾页"
ElseIf I=1 And I=TotalPage Then
PageStr ="首页 上一页 下一页 尾页"
ElseIf (I=TotalPage And I <> 2) Then
PageStr="首页上一页 下一页 尾页"
ElseIf(I = TotalPage And I = 2) Then
PageStr="首页上一页 下一页 尾页"
ElseIf(I = 2) Then
PageStr="首页上一页下一页尾页"
Else
PageStr="首页上一页下一页尾页"
End If
PageStr="共 " & Fcls.TotalPut & " " & FCls.ItemUnit &" 页次: " & I & "/" & TotalPage & "页 " & FCls.PerPageNum & "" & FCls.ItemUnit &"/页 " & PageStr
Case 2,3
PageStr="第" & I & "页 共" & TotalPage & "页 "
If I=1 Then
PageStr=PageStr & "97 "
ElseIf I=2 Then
PageStr=PageStr & "97 "
Else
PageStr=PageStr & "97 "
End If
If FCls.PageStyle=2 Then
PageStr=PageStr & " "
Dim startpage:startpage=1
Dim P,n:n=1
If I>10 Then startpage=(I/10-1)*10+(i mod 10)+1
for p=startpage to TotalPage
If P=1 Then
If (P=I) Then
PageStr=PageStr & "[" & P & "] "
else
PageStr=PageStr & "[" & P & "] "
End If
Else
if (p=i) Then
PageStr=PageStr & "[" & i & "] "
else
PageStr=PageStr & "[" & p & "] "
end if
End If
n=n+1
if n>10 Then Exit For
Next
PageStr=PageStr & ""
End If
If I=TotalPage Then
PageStr=PageStr & "8:"
Else
PageStr=PageStr & "8:"
End If
case 4 '新增样式
n=0:startpage=1
PageStr="
" & vbcrlf
if (I>1) then pageStr=PageStr & "上一页"
if (I<>TotalPage) then pageStr=PageStr & "下一页"
pageStr=pageStr & "首 页"
if (I>=7) then startpage=I-5
if TotalPage-I<5 Then startpage=TotalPage-10
If startpage<0 Then startpage=1
For p=startpage To TotalPage
If p= I Then
PageStr=PageStr & " " & p &""
Else
If P=1 Then
PageStr=PageStr & " " & p &""
Else
PageStr=PageStr & " " & p &""
End If
End If
n=n+1
if n>=10 then exit for
Next
If TotalPage=1 Then
pageStr=pageStr & "末页"
Else
pageStr=pageStr & "末页"
End If
pageStr=PageStr & " 总共" & TotalPage & "页
"
End Select
If FCls.PageStyle<>4 Then
PageStr=PageStr &" 转到:"
End If
PageStr=PageStr & vbcrlf & ""&vbcrlf &""
FileStr = Replace(F_C, "{PageListStr}", PageContentArr(I-1)& "
" & PageStr & "
")
'===============分页静态化结束=====================================================
FileStr = ReplaceRA(FileStr, SecondDomain)
if (TotalPage-I+1>0) Then
Dim TempFilePath
If I = 1 Then
TempFilePath = FilePath & Index
Else
TempFilePath = FilePath & Fname & "_" & TotalPage-I+1 & FExt
End If
Call FSOSaveFile(FileStr, TempFilePath)
End If
Loop
If FCls.RefreshType="Folder" And LoopEnd>5 Then KS.Echo ""
Dim JSStr
JSStr="var TotalPage=" & TotalPage & ";"&vbcrlf & "var TotalPut=" & KS.ChkClng(Fcls.TotalPut) & ";" &vbcrlf
JSStr=JSStr & "document.write("""");"&vbcrlf
Call FSOSaveFile(JSStr,FilePath&"page" & FCls.RefreshFolderID & ".html")
End Sub
'*********************************************************************************************************
'函数名:ReplaceGeneralLabelContent
'作 用:替换通用标签为内容
'参 数:FileContent原文件
'*********************************************************************************************************
Function ReplaceGeneralLabelContent(F_C)
'出现频率较高的标签直接在这里替换掉,提高性能
If Instr(F_C,"{$GetInstallDir}")<>0 Then F_C=Replace(F_C,"{$GetInstallDir}",DomainStr)
If Instr(F_C,"{$GetSiteUrl}")<>0 Then F_C=Replace(F_C,"{$GetSiteUrl}",Domainstr)
If Instr(F_C,"{$GetClubInstalldir}")<>0 Then F_C=Replace(F_C,"{$GetClubInstalldir}",KS.Setting(66))
Templates=""
Scan F_C
ReplaceGeneralLabelContent = Templates
End Function
Function GetTags(TagType,Num)
if not isnumeric(num) then exit function
dim sqlstr,sql,i,n,str
select case cint(tagtype)
case 1:sqlstr="select top 500 keytext,hits from ks_keywords where IsSearch=0 order by hits desc"
case 2:sqlstr="select top 500 keytext,hits from ks_keywords where IsSearch=0 order by lastusetime desc,id desc"
case 3:sqlstr="select top 500 keytext,hits from ks_keywords where IsSearch=0 order by Adddate desc,id desc"
case else
GetTags="":exit function
end select
dim rs:set rs=conn.execute(sqlstr)
if rs.eof then rs.close:set rs=nothing:exit function
sql=rs.getrows(-1)
rs.close:set rs=nothing
for i=0 to ubound(sql,2)
if KS.FoundInArr(str,sql(0,i),",")=false then
n=n+1
str=str & "," & sql(0,i)
gettags=gettags & "" & sql(0,i) & " "
end if
if n>=cint(num) then exit for
next
End Function
'*********************************************************************************************************
'函数名:GetSiteCountAll
'作 用:替换网站统计标签为内容
'参 数:Flag-0总统计,1-文章统计 2-图片统计
'*********************************************************************************************************
Function GetSiteCountAll()
Dim ChannelTotal: ChannelTotal = Conn.Execute("Select Count(*) From KS_Class Where TN='0'")(0)
Dim MemberTotal:MemberTotal=Conn.Execute("Select Count(*) From KS_User")(0)
Dim CommentTotal: CommentTotal = Conn.Execute("Select Count(*) From KS_Comment")(0)
Dim GuestBookTotal:GuestBookTotal=Conn.Execute("Select Count(ID) From KS_GuestBook")(0)
GetSiteCountAll="
" & vbcrlf
GetSiteCountAll = GetSiteCountAll & "
频道总数: " & ChannelTotal & " 个
" & vbcrlf
dim rsc:set rsc=conn.execute("select channelid,ItemName,Itemunit,channeltable from ks_channel where channelstatus=1 and channelid<>6 And ChannelID<>9 and channelid<>10 and channelid<>11")
dim k,sql:sql=rsc.getrows(-1)
rsc.close:set rsc=nothing
for k=0 to ubound(sql,2)
GetSiteCountAll = GetSiteCountAll & "
" & vbcrlf
next
GetSiteCountAll = GetSiteCountAll & "
注册会员: " & MemberTotal & " 位
" & vbcrlf
GetSiteCountAll = GetSiteCountAll & "
留言总数: " & GuestBookTotal &" 条
" & vbcrlf
GetSiteCountAll = GetSiteCountAll & "
评论总数: " & CommentTotal & " 条
" & vbcrlf
GetSiteCountAll = GetSiteCountAll & "
在线人数: 人
" & vbcrlf
GetSiteCountAll = GetSiteCountAll & "
" & vbcrlf
End Function
Function ReplaceKeyTags(KeyStr)
On error resume next
Dim I,K_Arr:K_Arr=Split(KeyStr,",")
For I=0 To Ubound(K_Arr)
ReplaceKeyTags=ReplaceKeyTags & "" & K_Arr(i) & " "
Next
If Err Then ReplaceKeyTags="":Err.Clear
End Function
'替换画中画广告
Function ReplaceAD(ByVal Content,ClassID)
Dim ShowADTF,CLen,Dir,Width,Height,AdUrl,AdLinkUrl,LC,RC,AdStr,ADType
Dim ClassBasicInfo:ClassBasicInfo=KS.C_C(ClassID,6)
If ClassBasicInfo="" Then Exit Function
Dim AdP:AdP = Split(Split(ClassBasicInfo,"||||")(4),"%ks%")
ShowADTF=KS.ChkClng(Adp(0))
If ShowADTF=0 Then ReplaceAD=Content:Exit Function
Dim Param:Param=Split(AdP(1),",")
CLen=KS.ChkClng(Param(0)):Dir=Param(1):Width=KS.ChkClng(Param(2)):Height=KS.ChkClng(Param(3)):AdUrl=Adp(3):AdLinkUrl=Adp(4):ADType=KS.ChkClng(ADP(2))
If CLen<>0 Then LC=InterceptString(Content,Clen)
RC=Right(Content,Len(Content)-Len(LC))
If ADType=2 Then
Adstr="
" & AdUrl & "
"
Else
If Lcase(Right(AdUrl,3))="swf" Then'判断是否Swf图片
AdStr="
"
Else
If AdLinkUrl="" Then AdLinkUrl="http://www.kesion.com"
AdStr="