<% '**************************************************** ' 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 & "" tempstr=tempstr & "
     下载信息  [文件大小:" & FileSize &" 下载次数: 次]" tempstr=tempstr & "
    " & Title & "
    " 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 &"]","" & strarr(k-1) & "") 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&"
  • " & Split(ContentArr(n), "|")(0) & "
    " & KS.Gottopic(Split(ContentArr(n), "|")(0),15) & "
  • " 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) & "
    " & 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 & "9 7 " ElseIf I=2 Then PageStr=PageStr & "9 7 " Else PageStr=PageStr & "9 7 " 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 & "
  • " & sql(1,k) & "总数: " & Conn.Execute("Select Count(id) From " & sql(3,k))(0) & " " & sql(2,k)&"
  • " & 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="
    " End If End If ReplaceAD=LC & AdStr & RC End Function '截取字符串 Function InterceptString(ByVal txt,length) Dim x,y,ii,c,ischines,isascii,tempStr length=Cint(length) txt=trim(txt):x = len(txt):y = 0 if x >= 1 then for ii = 1 to x c=asc(mid(txt,ii,1)) if c< 0 or c >255 then y = y + 2:ischines=1:isascii=0 else y = y + 1:ischines=0:isascii=1 end if if y >= length then if ischines=1 and StrCount(left(trim(txt),ii),"") then txt = left(txt,ii) '"字符串限长 exit for else if isascii=1 then x=x+1 end if end if next InterceptString = txt else InterceptString = "" end if End Function '判断字符串出现的次数 Public Function StrCount(Str,SubStr) Dim iStrCount,iStrStart,iTemp iStrCount = 0:iStrStart = 1:iTemp = 0:Str=LCase(Str):SubStr=LCase(SubStr) Do While iStrStart < Len(Str) iTemp = Instr(iStrStart,Str,SubStr,vbTextCompare) If iTemp <=0 Then iStrStart = Len(Str) Else iStrStart = iTemp + Len(SubStr) iStrCount = iStrCount + 1 End If Loop StrCount = iStrCount End Function Sub ReplaceHits(F_C,ChannelID,Id) If InStr(F_C, "{$GetHits}") <> 0 Then '总浏览数 F_C = Replace(F_C, "{$GetHits}", "") F_C = Replace(F_C, "{$GetHitsByDay}", "") F_C = Replace(F_C, "{$GetHitsByWeek}", "") F_C = Replace(F_C, "{$GetHitsByMonth}", "") ElseIf InStr(F_C, "{$GetHitsByDay}") <> 0 Then '本日浏览数 F_C = Replace(F_C, "{$GetHits}", "") F_C = Replace(F_C, "{$GetHitsByDay}", "") F_C = Replace(F_C, "{$GetHitsByWeek}", "") F_C = Replace(F_C, "{$GetHitsByMonth}", "") ElseIf InStr(F_C, "{$GetHitsByWeek}") <> 0 Then '本周浏览数 F_C = Replace(F_C, "{$GetHits}", "") F_C = Replace(F_C, "{$GetHitsByDay}", "") F_C = Replace(F_C, "{$GetHitsByWeek}", "") F_C = Replace(F_C, "{$GetHitsByMonth}", "") ElseIf InStr(F_C, "{$GetHitsByMonth}") <> 0 Then '本月浏览数 F_C = Replace(F_C, "{$GetHits}", "") F_C = Replace(F_C, "{$GetHitsByDay}", "") F_C = Replace(F_C, "{$GetHitsByWeek}", "") F_C = Replace(F_C, "{$GetHitsByMonth}", "") End If End Sub Function GetMoviePagePlay(Param) Dim Str,url dim MovieUrlsArr:MovieUrlsArr = Split(GetNodeText("movieurls"),"|||") Dim Marr:Marr=Split(MovieUrlsArr(0),"|") IF GetNodeText("serverid")=9999 and lcase(left(marr(1),4)="http") then url=marr(1) ElseIf GetNodeText("serverid")=0 Then url= marr(1) Else url= Conn.Execute("Select Url1 From KS_MediaServer Where ID=" & KS.ChkClng(GetNodeText("serverid")))(0)&marr(1) End If select case lcase(Mid(Trim(Marr(1)), InStrRev(Trim(Marr(1)), "."))) case ".flv" Str="" &vbcrlf case ".rm",".rmvb",".rt",".ra",".rp",".rv" str="
    " case ".swf" str = "" & vbCrLf str = str & "" & vbCrLf str = str & "" & vbCrLf str = str & "" & vbCrLf str = str & "" & vbCrLf case else str="" end select GetMoviePagePlay=str End Function Function GetProductType(TypeID) Select Case TypeID Case 1:GetProductType="正常销售" Case 2:GetProductType="涨价销售" Case 3:GetProductType="降价销售" End Select End Function '************************************************** '函数名:Published '作 用:取得发布时间及版权信息 '参 数:无 '************************************************** Function Published() On Error Resume Next Published=vbcrlf &"" & vbcrlf Dim PublishInfo:PublishInfo = KS.Setting(15) If PublishInfo <> "0" Then Published = Published & "" & vbCrLf End If End Function '================================================= '函数名:GetVote '作 用:显示网站调查 '================================================= Function GetVote(VoteID) dim sqlVote,rsVote,i,XML,Node If KS.ChkClng(VoteID)=0 Then sqlVote="select top 1 * from KS_Vote Order By NewestTF Desc" Else sqlVote="select top 1 * from KS_Vote where ID=" & VoteID & " Order By NewestTF Desc" End If Set rsVote= conn.execute(sqlvote) if rsVote.bof and rsVote.eof then GetVote= "没有任何调查!" else VoteID=RSVote("ID") GetVote=GetVote & "
    " & vbcrlf GetVote=GetVote & "
    " &vbcrlf GetVote=GetVote & ""&vbcrlf GetVote=GetVote & "
    "& rsVote("Title") &"
    "&vbcrlf Set XML=LFCls.GetXMLFromFile("voteitem/vote_"&VoteID) If IsObject(XML) Then if rsVote("VoteType")="Single" then for each node in Xml.DocumentElement.SelectNodes("voteitem") GetVote=GetVote & "" & Node.childNodes(0).text &"
    "&vbcrlf Next else for each node in Xml.DocumentElement.SelectNodes("voteitem") GetVote=GetVote & " "& Node.childNodes(0).text &"
    "&vbcrlf next end if End If GetVote=GetVote & ""&vbcrlf GetVote=GetVote & ""&vbcrlf GetVote=GetVote & "
    "&vbcrlf GetVote=GetVote & " "&vbcrlf GetVote=GetVote & ""&vbcrlf GetVote=GetVote & "
    "&vbcrlf GetVote=GetVote & "
    "&vbcrlf end if rsVote.close:set rsVote=nothing End Function '显示会员登录排行 Sub GetTopUser(Num,MoreStr) Dim Sql,XML,Node,UserFace,UserName Dim RSObj:Set RSObj=Conn.execute("Select Top " & Num &" UserID,UserName,UserFace,LoginTimes,sex From KS_User where groupid<>1 Order BY LoginTimes Desc,UserID Desc") If Not RSObj.Eof Then Set Xml=KS.RsToXml(RSObj,"row","") RSObj.Close : Set RSObj = Nothing If IsObject(Xml) Then For each Node In Xml.DocumentElement.SelectNodes("row") userface=Node.SelectSingleNode("@userface").text : UserName=Node.SelectSingleNode("@username").text if userface="" then if Node.SelectSingleNode("@sex").text="男" then userface="images/face/0.gif" else userface="images/face/girl.gif" End If If Left(Lcase(userface),4)<>"http" Then userface=DomainStr & userface echoln "

  • " & UserName & "
  • " Next If MoreStr<>"" Then Echo "
    " & MoreStr & "
    " Xml=Empty : Set Node=Nothing End If End Sub '显示会员动态 Sub GetUserDynamic(Num) Dim RS,XML,Node Set RS=Conn.Execute("Select Top " & Num & " id,username,Note,adddate,ico From KS_UserLog Order By Id Desc") If Not RS.Eof Then Set XML=KS.RsToXml(RS,"row","") RS.Close:Set RS=Nothing If IsObject(XML) Then for each Node In XML.DocumentElement.SelectNodes("row") echoln "
  • " & KS.GetTimeFormat(Node.SelectSingleNode("@adddate").text) & "" & Node.SelectSingleNode("@username").text & " " & Replace(Replace(Replace(Replace(Node.SelectSingleNode("@note").text,"{$GetSiteUrl}",DomainStr),vbcrlf,""),"

    ",""),"

    ","") & "
  • " next XML=Empty : Set Node=Nothing End If End Sub Function FormatImglink(content,url,totalpage) dim re:Set re=new RegExp re.IgnoreCase =true re.Global=True '去除onclick,onload等脚本 're.Pattern = "\s[on].+?=([\""|\'])(.*?)\1" 'Content = re.Replace(Content, "") Dim LinkStr If TotalPage=1 Then LinkStr="href=""$2"" target=""_blank""" Else LinkStr="href=""" & Url & """" End If '将SRC不带引号的图片地址加上引号 re.Pattern = "]*).*?>" Content = re.Replace(Content, "") '正则匹配图片SRC地址 re.Pattern = "" Content = re.Replace(Content, "") set re = nothing FormatImglink = content end function End Class %>