<% dim UserLogined,UserName,UserLevel,ChargeType,UserPoint,ValidDays '************************************************** '函数名:gotTopic '作 用:截字符串,汉字一个算两个字符,英文算一个字符 '参 数:str ----原字符串 ' strlen ----截取长度 '返回值:截取后的字符串 '************************************************** function gotTopic(str,strlen) if str="" then gotTopic="" exit function end if dim l,t,c, i str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<") l=len(str) t=0 for i=1 to l c=Abs(Asc(Mid(str,i,1))) if c>255 then t=t+2 else t=t+1 end if if t>=strlen then gotTopic=left(str,i) & "…" exit for else gotTopic=str end if next gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<") end function '************************************************** '函数名:JoinChar '作 用:向地址中加入 ? 或 & '参 数:strUrl ----网址 '返回值:加了 ? 或 & 的网址 '************************************************** function JoinChar(strUrl) if strUrl="" then JoinChar="" exit function end if if InStr(strUrl,"?")1 then if InStr(strUrl,"&")" & totalnumber & " " & strUnit & "  " end if strUrl=JoinChar(sfilename) if CurrentPage<2 then strTemp=strTemp & "首页 上一页 " else strTemp=strTemp & "首页 " strTemp=strTemp & "上一页 " end if if n-currentpage<1 then strTemp=strTemp & "下一页 尾页" else strTemp=strTemp & "下一页 " strTemp=strTemp & "尾页" end if strTemp=strTemp & " 页次:" & CurrentPage & "/" & n & "页 " strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页" if ShowAllPages=True then strTemp=strTemp & " 转到:" end if strTemp=strTemp & "" response.write strTemp end sub '************************************************** '过程名:showpage2 '作 用:显示“上一页 下一页”等信息 '参 数:sfilename ----链接地址 ' totalnumber ----总数量 ' maxperpage ----每页数量 '************************************************** sub showpage2(sfilename,totalnumber,maxperpage) dim n,i,strTemp,strUrl,format format = "上一页 下一页 首页 未页 第 {CurrentPage}/{maxpage}页" if totalnumber mod maxperpage=0 then n= totalnumber \ maxperpage else n= totalnumber \ maxperpage+1 end if format = replace(format,"{totalnumber}",totalnumber) format = replace(format,"{maxperpage}",maxperpage) format = replace(format,"{CurrentPage}",CurrentPage) format = replace(format,"{maxpage}",n) strUrl=JoinChar(sfilename) if CurrentPage<2 then format = replace(format,"{indexpage}","#") format = replace(format,"{prvepage}","#") else format = replace(format,"{indexpage}",strUrl & "page=1'") format = replace(format,"{prvepage}",strUrl & "page=" & (CurrentPage-1)) end if if n-CurrentPage<1 then format = replace(format,"{nextpage}","#") format = replace(format,"{Footpage}","#") else format = replace(format,"{nextpage}",strUrl & "page=" & (CurrentPage+1)) format = replace(format,"{Footpage}",strUrl & "page=" & n) end if response.write format end sub '************************************************** '函数名:IsValidEmail '作 用:检查Email地址合法性 '参 数:email ----要检查的Email地址 '返回值:True ----Email地址合法 ' False ----Email地址不合法 '************************************************** function IsValidEmail(email) dim names, name, i, c IsValidEmail = true names = Split(email, "@") if UBound(names) <> 1 then IsValidEmail = false exit function end if for each name in names if Len(name) <= 0 then IsValidEmail = false exit function end if for i = 1 to Len(name) c = Lcase(Mid(name, i, 1)) if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then IsValidEmail = false exit function end if next if Left(name, 1) = "." or Right(name, 1) = "." then IsValidEmail = false exit function end if next if InStr(names(1), ".") <= 0 then IsValidEmail = false exit function end if i = Len(names(1)) - InStrRev(names(1), ".") if i <> 2 and i <> 3 then IsValidEmail = false exit function end if if InStr(email, "..") > 0 then IsValidEmail = false end if end function '************************************************** '函数名:IsObjInstalled '作 用:检查组件是否已经安装 '参 数:strClassString ----组件名 '返回值:True ----已经安装 ' False ----没有安装 '************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function '************************************************** '函数名:strLength '作 用:求字符串长度。汉字算两个字符,英文算一个字符。 '参 数:str ----要求长度的字符串 '返回值:字符串长度 '************************************************** function strLength(str) ON ERROR RESUME NEXT dim WINNT_CHINESE WINNT_CHINESE = (len("中国")=2) if WINNT_CHINESE then dim l,t,c dim i l=len(str) t=l for i=1 to l c=asc(mid(str,i,1)) if c<0 then c=c+65536 if c>255 then t=t+1 end if next strLength=t else strLength=len(str) end if if err.number<>0 then err.clear end function '------------------检查某一目录是否存在------------------- Function CheckDir(FolderPath) dim fso folderpath=Server.MapPath(".")&"\"&folderpath Set fso1 = Server.CreateObject("Scripting.FileSystemObject") If fso.FolderExists(FolderPath) then '存在 CheckDir = True Else '不存在 CheckDir = False End if Set fso = nothing End Function '-------------根据指定名称生成目录--------- Function MakeNewsDir(foldername) dim fso,f Set fso = Server.CreateObject("Scripting.FileSystemObject") Set f = fso.CreateFolder(foldername) MakeNewsDir = True Set fso = nothing End Function '************************************************** '函数名:SendMail '作 用:用Jmail组件发送邮件 '参 数:MailtoAddress ----收信人地址 ' MailtoName -----收信人姓名 ' Subject -----主题 ' MailBody -----信件内容 ' FromName -----发信人姓名 ' MailFrom -----发信人地址 ' Priority -----信件优先级 '************************************************** function SendMail(MailtoAddress,MailtoName,Subject,MailBody,FromName,MailFrom,Priority) on error resume next Dim JMail Set JMail=Server.CreateObject("JMail.Message") if err then SendMail= "
  • 没有安装JMail组件
  • " err.clear exit function end if JMail.Charset="gb2312" '邮件编码 JMail.silent=true JMail.ContentType = "text/html" '邮件正文格式 'JMail.ServerAddress=MailServer '用来发送邮件的SMTP服务器 '如果服务器需要SMTP身份验证则还需指定以下参数 JMail.MailServerUserName = MailServerUserName '登录用户名 JMail.MailServerPassWord = MailServerPassword '登录密码 JMail.MailDomain = MailDomain '域名(如果用“name@domain.com”这样的用户名登录时,请指明domain.com JMail.AddRecipient MailtoAddress,MailtoName '收信人 JMail.Subject=Subject '主题 JMail.HMTLBody=MailBody '邮件正文(HTML格式) JMail.Body=MailBody '邮件正文(纯文本格式) JMail.FromName=FromName '发信人姓名 JMail.From = MailFrom '发信人Email JMail.Priority=Priority '邮件等级,1为加急,3为普通,5为低级 JMail.Send(MailServer) SendMail =JMail.ErrorMessage JMail.Close Set JMail=nothing end function '************************************************** '过程名:WriteErrMsg '作 用:显示错误提示信息 '参 数:无 '************************************************** sub WriteErrMsg() dim strErr strErr=strErr & "错误信息" & vbcrlf strErr=strErr & "

    " & vbcrlf strErr=strErr & "" & vbcrlf strErr=strErr & " " & vbcrlf strErr=strErr & " " & vbcrlf strErr=strErr & " " & vbcrlf strErr=strErr & "
    错误信息
    产生错误的可能原因:" & errmsg &"
    << 返回上一页
    " & vbcrlf strErr=strErr & "" & vbcrlf response.write strErr end sub '************************************************** '过程名:WriteSuccessMsg '作 用:显示成功提示信息 '参 数:无 '************************************************** sub WriteSuccessMsg(SuccessMsg) dim strSuccess strSuccess=strSuccess & "成功信息" & vbcrlf strSuccess=strSuccess & "

    " & vbcrlf strSuccess=strSuccess & "" & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & "
    恭喜你!

    " & SuccessMsg & "
     
    " & vbcrlf strSuccess=strSuccess & "" & vbcrlf response.write strSuccess end sub '************************************************** '过程名:WriteSuccessMsg2 '作 用:显示成功提示信息 '参 数:无 '************************************************** sub WriteSuccessMsg2(SuccessMsg,path) dim strSuccess strSuccess=strSuccess & "成功信息" & vbcrlf strSuccess=strSuccess & "

    " & vbcrlf strSuccess=strSuccess & "" & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & " " & vbcrlf strSuccess=strSuccess & "
    恭喜你!

    " & SuccessMsg & "
    返回
    " & vbcrlf strSuccess=strSuccess & "" & vbcrlf response.write strSuccess end sub '************************************************** '函数名:CheckUserLogined '作 用:检查用户是否登录 '参 数:无 '返回值:True ----已经登录 ' False ---没有登录 '************************************************** function CheckUserLogined() dim Logined,Password,rsLogin,sqlLogin Logined=True UserName=Request.Cookies("asp163")("UserName") Password=Request.Cookies("asp163")("Password") UserLevel=Request.Cookies("asp163")("UserLevel") if UserName="" then Logined=False end if if Password="" then Logined=False end if if UserLevel="" then Logined=False UserLevel=9999 end if if Logined=True then username=replace(trim(username),"'","") password=replace(trim(password),"'","") UserLevel=Cint(trim(UserLevel)) set rsLogin=server.createobject("adodb.recordset") sqlLogin="select * from " & db_User_Table & " where " & db_User_LockUser & "=False and " & db_User_Name & "='" & username & "' and " & db_User_Password & "='" & password &"'" rsLogin.open sqlLogin,Conn_User,1,1 if rsLogin.bof and rsLogin.eof then Logined=False else if password<>rsLogin(db_User_Password) or UserLevel"" then response.write "" if lcase(right(LogoUrl,3))<>"swf" then response.write "" else Response.Write "" end if response.write "" else response.write "" end if end sub '================================================== '过程名:ShowBanner '作 用:显示网站Banner '参 数:无 '================================================== sub ShowBanner() if BannerUrl<>"" then if lcase(right(BannerUrl,3))="swf" then Response.Write "" else response.Write "" end if else call ShowAD(1) end if end sub '================================================== '过程名:ShowVote '作 用:显示网站调查 '参 数:无 '================================================== sub ShowVote() dim sqlVote,rsVote,i sqlVote="select top 1 * from Vote where IsSelected=True" sqlVote=sqlVote& " and (ChannelID=0 or ChannelID=" & ChannelID & ") order by ID Desc" Set rsVote= Server.CreateObject("ADODB.Recordset") rsVote.open sqlVote,conn,1,1 if rsVote.bof and rsVote.eof then response.Write " 没有任何调查" else response.write "
    " response.write "    " & rsVote("Title") & "
    " if rsVote("VoteType")="Single" then for i=1 to 8 if trim(rsVote("Select" & i) & "")="" then exit for response.Write "" & rsVote("Select" & i) & "
    " next else for i=1 to 8 if trim(rsVote("Select" & i) & "")="" then exit for response.Write "" & rsVote("Select" & i) & "
    " next end if response.write "
    " response.write "" response.write "" response.write "
    " response.write "  " response.write "" response.write "
    " end if rsVote.close set rsVote=nothing end sub '================================================== '过程名:ShowAnnounce '作 用:显示本站公告信息 '参 数:ShowType ------显示方式,1为纵向,2为横向 ' AnnounceNum ----最多显示多少条公告 '================================================== sub ShowAnnounce(ShowType,AnnounceNum) dim sqlAnnounce,rsAnnounce,i if AnnounceNum < 0 then AnnounceNum = 20 end if sqlAnnounce="select top " & AnnounceNum sqlAnnounce=sqlAnnounce & " * from Announce where IsSelected=True" sqlAnnounce=sqlAnnounce & " and (ChannelID=0 or ChannelID=" & ChannelID & ")" sqlAnnounce=sqlAnnounce & " and (ShowType=0 or ShowType=1) order by ID Desc" Set rsAnnounce= Server.CreateObject("ADODB.Recordset") rsAnnounce.open sqlAnnounce,conn,1,1 if rsAnnounce.bof and rsAnnounce.eof then AnnounceCount=0 response.write "

    没有通告

    " else AnnounceCount=rsAnnounce.recordcount dim movetype movetype = "" do while not rsAnnounce.eof response.Write "" & rsAnnounce("title") & " [" & rsAnnounce("Author") & " " & FormatDateTime(rsAnnounce("DateAndTime"),1) & "]" if ShowType=1 then response.write "
    " end if rsAnnounce.movenext loop response.write "
    " end if rsAnnounce.close set rsAnnounce=nothing end sub '================================================== '过程名:ShowFriendSite '作 用:显示友情链接站点 '参 数:LinkType ----链接方式,1为LOGO链接,2为文字链接 '================================================== sub ShowFriendSite(LinkType) dim sqlLink,rsLink,format,temp if LinkType<>1 and LinkType<>2 then LinkType=1 else LinkType=Cint(LinkType) end if format = "" if LinkType=1 then format = format + "" elseif LinkType=2 then format = format + "{SiteName}" end if format = format + "
    " sqlLink="select * from FriendSite where IsOK=True and LinkType=" & LinkType & " order by IsGood,id desc" set rsLink=server.createobject("adodb.recordset") rsLink.open sqlLink,conn,1,1 do while not rsLink.eof if LinkType=cint(rsLink("LinkType")) and rsLink("IsGood")=true and rsLink("IsOK")=true then temp = replace(format,"{SiteUrl}",rsLink("SiteUrl")) temp = replace(temp,"{SiteName}",rsLink("SiteName")) temp = replace(temp,"{SiteIntro}",rsLink("SiteUrl")) temp = replace(temp,"{LogoUrl}",rsLink("LogoUrl")) response.Write temp end if rsLink.moveNext loop rsLink.close set rsLink=nothing end sub '================================================== '过程名:RollFriendSite '作 用:滚动显示友情链接站点 '参 数:无 '================================================== sub RollFriendSite() %> <% end sub sub ShowGoodSite(SiteNum) dim sqlLink,rsLink,SiteCount,i,strLink if SiteNum<=0 or SiteNum>100 then SiteNum=10 end if strLink=strLink & "" sqlLink="select top " & SiteNum & " * from FriendSite where IsOK=True and LinkType=1 and IsGood=True order by id desc" set rsLink=server.createobject("adodb.recordset") rsLink.open sqlLink,conn,1,1 if rsLink.bof and rsLink.eof then for i=1 to SiteNum strLink=strLink & "" next else SiteCount=rsLink.recordcount for i=1 to SiteCount strLink=strLink & "" rsLink.moveNext next for i=SiteCount+1 to SiteNum strLink=strLink & "" next end if strLink=strLink & "
    点击申请
    " if rsLink("LogoUrl")="" or rsLink("LogoUrl")="http://" then strLink=strLink & "" else strLink=strLink & "" end if strLink=strLink & "
    点击申请
    " response.write strLink rsLink.close set rsLink=nothing end sub sub Bottom() dim strTemp strTemp="
    " strTemp= strTemp & "| 设"&"为"&"首"&"页 | " strTemp= strTemp & "加"&"入"&"收"&"藏 | " strTemp= strTemp & "联"&"系"&"站"&"长 | " strTemp= strTemp & "友"&"情"&"链"&"接 | " strTemp= strTemp & "版"&"权"&"申"&"明 | " strTemp= strTemp & "管"&"理"&"登"&"录 | " strTemp= strTemp & "
    " strTemp= strTemp & Copyright strTemp= strTemp & "        站长:" & WebmasterName & "" if ShowRunTime="Yes" then strTemp= strTemp & "        页"&"面"&"执"&"行"&"时"&"间:" & CStr(FormatNumber((Timer-BeginTime)*1000,2)) & "毫秒" end if strTemp= strTemp & "
    Powe"&"red by:吉秀科技" strTemp= strTemp & "
    " response.write strTemp end sub '================================================== '过程名:ShowUserLogin '作 用:显示用户登录表单 '参 数:无 '================================================== sub ShowUserLogin() dim strLogin if CheckUserLogined()=False then strLogin="" & vbcrlf strLogin=strLogin & "" & vbcrlf strLogin=strLogin & "" & vbcrlf strLogin=strLogin & "" & vbcrlf strLogin=strLogin & "" & vbcrlf strLogin=strLogin & "" & vbcrlf strLogin=strLogin & "
    用户名:
    密  码:
    Cookie:
    " & vbcrlf strLogin=strLogin & "

    新用户注册  忘记密码?
    " & vbcrlf response.write strLogin %> <% Else response.write "欢迎您!" & UserName & ",好久不见!" response.write "
    您的身份:" if UserLevel=999 then response.write "注册用户" elseif UserLevel=99 then response.write "收费用户" elseif UserLevel=9 then response.write "VIP用户" end if response.write "
    计费方式:" if ChargeType=1 then if UserPoint>0 then response.write "扣点数
    可用点数: " & UserPoint & " 点" if UserPoint<=10 then response.write "
    你的可用点数已不多,请及时联系我们进行充值!" end if else response.write "扣点数
    可用点数: " & UserPoint & " 点" response.write "
    你的可用点数已经用完,请联系我们进行充值,否则你将不能阅读收费内容。" end if else if ValidDays>0 then response.write "有效期
    有效天数: " & ValidDays & " 天" if ValidDays<=10 then response.write "
    你的有效期时间已不长,请及时联系我们进行充值!" end if else response.write "有效期
    有效天数: " & ValidDays & " 天" response.write "
    你的有效期已经过期,请联系我们进行充值,否则你将不能阅读收费内容。" end if end if response.write "
    用户控制面板:
    " & vbcrlf response.write "   发表文章" & vbcrlf response.write "  文章管理
    " & vbcrlf response.write "   修改密码" & vbcrlf response.write "  个人信息
    " & vbcrlf response.write "
    【注销登录】
    " & vbcrlf end if %> <% end sub '================================================== '过程名:ShowTopUser '作 用:显示用户排行,按已发表的文章数排序,若相等,再按注册先后顺序排序 '参 数:UserNum-------显示的用户个数 '================================================== sub ShowTopUser(UserNum) if UserNum<=0 or UserNum>100 then UserNum=10 dim sqlTopUser,rsTopUser,i sqlTopUser="select top " & UserNum & " * from " & db_User_Table & " order by " & db_User_ArticleChecked & " desc," & db_User_ID & " asc" set rsTopUser=server.createobject("adodb.recordset") rsTopUser.open sqlTopUser,Conn_User,1,1 if rsTopUser.bof and rsTopUser.eof then response.write "没有任何用户" else response.write "" for i=1 to rsTopUser.recordcount response.write "" rsTopUser.movenext next response.write "
    名次用户名文章数
    " & cstr(i) & "" & rsTopUser(db_User_Name) & "" & rsTopUser(db_User_ArticleChecked) & "
    more...
    " end if set rsTopUser=nothing end sub '================================================== '过程名:ShowAllUser '作 用:分页显示所有用户 '参 数:无 '================================================== sub ShowAllUser() select case OrderType case 1 sqlUser="select * from " & db_User_Table & " order by " & db_User_ArticleChecked & " desc" case 2 sqlUser="select * from " & db_User_Table & " order by " & db_User_RegDate & " desc" case 3 sqlUser="select * from " & db_User_Table & " order by " & db_User_ID & " desc" end select set rsUser=server.createobject("adodb.recordset") rsUser.open sqlUser,Conn_User,1,1 if rsUser.bof and rsUser.eof then totalput=0 response.write "
  • 没有任何用户
  • " else totalput=rsUser.recordcount if currentPage=1 then call ShowUserList() else if (currentPage-1)*MaxPerPage
    按发表文章数排序    按注册日期排序    按用户ID排序
    " response.write "" do while not rsUser.eof response.write "" response.write "" rsUser.movenext i=i+1 if i>=MaxPerPage then exit do loop response.write "
    用户名性别EmailQQ号码MSN主页注册日期文章数
    " & rsUser(db_User_Name) & "" if rsUser(db_User_Sex)=1 then response.write "男" else response.write "女" end if response.write "" & rsUser(db_User_Email) & "" if rsUser(db_User_QQ)<>"" then response.write rsUser(db_User_QQ) else response.write "未填" end if response.write "" if rsUser(db_User_Msn)<>"" then response.write rsUser(db_User_Msn) else response.write "未填" end if response.write "" if rsUser(db_User_Homepage)<>"" and rsUser(db_User_Homepage)<>"http://" then response.write "点此访问" else response.write "未填" end if response.write "" & FormatDateTime(rsUser(db_User_RegDate),2) & "" & rsUser(db_User_ArticleChecked) & "
    " end sub '================================================== '过程名:PopAnnouceWindow '作 用:弹出公告窗口 '参 数:Width-------弹出窗口宽度 ' Height------弹出窗口高度 '================================================== sub PopAnnouceWindow(Width,Height) dim popCount,rsAnnounce set rsAnnounce=conn.execute("select count(*) from Announce where IsSelected=True and (ChannelID=0 or ChannelID=" & ChannelID & ") and (ShowType=0 or ShowType=2)") popCount=rsAnnounce(0) if popCount>0 then if PopAnnounce="Yes" and session("Poped")<>ChannelID then response.write "" session("Poped")=ChannelID end if end if end sub '================================================== '过程名:ShowPath '作 用:显示“你现在所有位置”导航信息 '参 数:无 '================================================== sub ShowPath() if PageTitle<>"" and ChannelID<>1 then strPath=strPath & " >> " & PageTitle end if response.write strPath end sub '================================================== '过程名:MenuJS '作 用:生成下拉菜单相关的JS代码 '参 数:无 '================================================== sub MenuJS() dim strMenu if ShowMyStyle="Yes" then %> <% response.write "" & vbcrlf else %> <% end if if ChannelID>=2 and ChannelID<=4 then '无限级下拉菜单的JS代码文件 response.write "" if ShowClassTreeGuide="Yes" then %> <% end if end if end sub '================================================== '过程名:ShowSearchForm '作 用:显示文章搜索表单 '参 数:ShowType ----显示方式。1为简洁模式,2为标准模式,3为高级模式 '================================================== sub ShowSearchForm(Action,ShowType) if ShowType<>1 and ShowType<>2 and ShowType<>3 then ShowType=1 end if response.write "" response.write "" response.write "
    " if ShowType=1 then response.write " " response.write "" response.write "" 'response.write "

    高级搜索" elseif Showtype=2 then response.write " " response.write "  " response.write "" elseif Showtype=3 then end if response.write "
    " end sub '================================================== '过程名:ShowGuest '作 用:显示网站留言 '参 数:GuestTitleLen ---显示留言标题长度 ' GuestItemNum ---显示留言条数 '================================================== sub ShowGuest(GuestTitleLen,GuestItemNum) dim sqlGuest,rsGuest if GuestItemNum<=0 or GuestItemNum>50 then GuestItemNum=10 end if sqlGuest="select top " & GuestItemNum & " * from Guest where GuestIsPassed=True order by GuestMaxId desc" Set rsGuest= Server.CreateObject("ADODB.Recordset") rsGuest.open sqlGuest,conn,1,1 if rsGuest.bof and rsGuest.eof then response.Write " 没有任何留言" else do while Not rsGuest.eof response.write "·" response.write gotTopic(rsGuest("GuestTitle"),GuestTitleLen) response.write "
    " rsGuest.movenext Loop end if rsGuest.close set rsGuest=nothing end sub '================================================== '过程名:ShowAD '作 用:显示广告 '参 数:ADType ---广告类型 '================================================== sub ShowAD(ADType) dim sqlAD,rsAD,AD,arrSetting,popleft,poptop,floatleft,floattop,fixedleft,fixedtop sqlAD="select * from Advertisement where IsSelected=True" sqlAD=sqlAD & " and (ChannelID=0 or ChannelID=" & ChannelID & ")" sqlAD=sqlAD & " and ADType=" & ADtype & " order by ID Desc" set rsAD=server.createobject("adodb.recordset") rsAD.open sqlAD,conn,1,1 if not rsAd.bof and not rsAD.eof then do while not rsAD.eof if rsAD("isflash")=true then AD= "0 then AD = AD & " width='" & rsAD("ImgWidth") & "'" if rsAD("ImgHeight")>0 then AD = AD & " height='" & rsAD("ImgHeight") & "'" AD = AD & ">0 then AD = AD & " width='" & rsAD("ImgWidth") & "'" if rsAD("ImgHeight")>0 then AD = AD & " height='" & rsAD("ImgHeight") & "'" AD = AD & ">" else AD ="0 then AD = AD & " width='" & rsAD("ImgWidth") & "'" if rsAD("ImgHeight")>0 then AD = AD & " height='" & rsAD("ImgHeight") & "'" AD = AD & " border='0'>" end if if ADtype=0 then if session("PopAD"&rsAD("ID")&ChannelID)<>True then if instr(rsAD("ADSetting"),"|")>0 then arrSetting=split(rsAD("ADSetting"),"|") popleft=arrsetting(0) poptop=arrsetting(1) end if response.write "" session("PopAD"&rsAD("ID")&ChannelID)=True end if elseif ADtype=1 then response.write AD exit do elseif ADtype=2 then response.write AD exit do elseif ADtype=3 then response.write AD exit do elseif ADtype=4 then if instr(rsAD("ADSetting"),"|")>0 then arrSetting=split(rsAD("ADSetting"),"|") floatleft=arrsetting(0) floattop=arrsetting(1) end if response.write "
    " & AD & "
    " call FloatAD() exit do elseif ADtype=5 then if instr(rsAD("ADSetting"),"|")>0 then arrSetting=split(rsAD("ADSetting"),"|") fixedleft=arrsetting(0) fixedtop=arrsetting(1) end if response.write "
    " & AD & "
    " call FixedAD() exit do end if rsAD.movenext loop end if rsAD.close set rsAD=nothing end sub '================================================== '过程名:FloatAD '作 用:浮动广告 '参 数:无 '================================================== sub FloatAD() %> <% end sub '================================================== '过程名:FixedAD '作 用:固定位置广告 '参 数:无 '================================================== sub FixedAD() %> <% end sub '================================================== '过程名:FixedAD1 '作 用:固定位置广告(图片位置超过窗口时卷动时有问题) '参 数:无 '================================================== sub FixedAD1() %> <% end sub '================================================== '过程名:ShowClassContent '作 用:显示类文章描述(分页) '参 数:classID ------类别号 '================================================= sub ShowClassContent(ClassID) dim rsClass,sqlClass '取出本类别信息 Set rsClass= Server.CreateObject("ADODB.Recordset") sqlClass="select Readme From ArticleClass where IsElite=True and LinkUrl='' and ClassID = "& ClassID rsClass.open sqlClass,conn,1,1 if not rsClass.eof then response.write rsClass("Readme") end if rsClass.close set rsClass=nothing end sub '================================================== '过程名:IsClassList '作 用:是否显示文章列表 '参 数:ClassID ------类别号 '================================================= function IsClassList(ClassID) dim rsClass,sqlClass '取出本类别信息 Set rsClass= Server.CreateObject("ADODB.Recordset") sqlClass="select IsClassList From ArticleClass where LinkUrl='' and ClassID = "& ClassID rsClass.open sqlClass,conn,1,1 if not rsClass.eof then IsClassList=rsClass(0) end if rsClass.close set rsClass=nothing end function '================================================== '过程名:ShowAllClass '作 用:制定类文章列表(分页) '参 数:classID ------类别号 ' ArticleNum --显示数 ' TitleLen ----标题最多字符数,一个汉字=两个英文字符 '================================================= sub ShowAllClass(ClassID,SpecialID,ArticleNum,TitleLen) if TitleLen<0 or TitleLen>200 then TitleLen=50 end if dim rsClass,sqlClass,rsArticle,sqlArticle,arrClassID,RootID,Child,isSpecial '取出本类别信息 Set rsClass= Server.CreateObject("ADODB.Recordset") sqlClass="select C.RootID,C.Child " sqlClass=sqlClass & "From ArticleClass C inner join Layout L on C.LayoutID=L.LayoutID " sqlClass=sqlClass & "where IsElite=True and LinkUrl='' and C.ClassID = "& ClassID &" " sqlClass=sqlClass & "order by C.RootID" rsClass.open sqlClass,conn,1,1 if not rsClass.eof then RootID = rsClass(0) Child = rsClass(1) '取出包括所有子类别ID arrClassID=ClassID if Child > 0 then rsClass.close rsClass.open "select ClassID from ArticleClass where RootID=" & RootID & " and Child=0 and LinkUrl=''",conn,1,1 do while not rsClass.eof arrClassID=arrClassID & "," & rsClass(0) rsClass.movenext loop end if '取出包括所有子类别记录 Set rsArticle= Server.CreateObject("ADODB.Recordset") sqlArticle="select A.ArticleID,A.Title,A.Author,A.TitleFontColor,A.TitleFontType,A.OnTop,A.Elite,A.IncludePic,L.LayoutFileName,A.Hits,A.UpdateTime " sqlArticle=sqlArticle & "from Article A inner join Layout L on A.LayoutID=L.LayoutID " sqlArticle=sqlArticle & "where A.Deleted=False and A.Passed=True and A.ClassID in (" & arrClassID & ") " if SpecialID > 0 then sqlArticle = sqlArticle & "and A.SpecialID=" & SpecialID & " " isSpecial = true else isSpecial = false end if sqlArticle=sqlArticle & "order by A.OnTop,A.ArticleID desc" rsArticle.open sqlArticle,conn,1,1 if not rsArticle.eof then totalput=rsArticle.recordcount if currentpage<1 then currentpage=1 end if if (currentpage-1)*ArticleNum>totalput then if (totalPut mod ArticleNum)=0 then currentpage= totalPut \ ArticleNum else currentpage= totalPut \ ArticleNum + 1 end if end if if currentPage <> 1 then if (currentPage-1)*ArticleNum 没有任何文章" end if rsArticle.close set rsArticle=nothing else totalput=0 response.write " 没有任何文章" end if rsClass.close set rsClass=nothing end sub '================================================== '过程名:ShowClass '作 用:制定类文章列表 '参 数:classID ------类别号 ' ArticleNum --显示数 ' TitleLen ----标题最多字符数,一个汉字=两个英文字符 ' isInfo ------是否显示帖子信息 '================================================= sub ShowClass(ClassID,ArticleNum,TitleLen,isInfo) if TitleLen<0 or TitleLen>200 then TitleLen=50 end if dim rsClass,sqlClass,rsArticle,sqlArticle,arrClassID,RootID,Child '取出本类别信息 Set rsClass= Server.CreateObject("ADODB.Recordset") sqlClass="select C.RootID,C.Child " sqlClass=sqlClass & "From ArticleClass C inner join Layout L on C.LayoutID=L.LayoutID " sqlClass=sqlClass & "where IsElite=True and LinkUrl='' and C.ClassID = "& ClassID &" " sqlClass=sqlClass & "order by C.RootID" rsClass.open sqlClass,conn,1,1 if not rsClass.eof then RootID = rsClass(0) Child = rsClass(1) '取出包括所有子类别ID arrClassID=ClassID if Child > 0 then rsClass.close rsClass.open "select ClassID from ArticleClass where RootID=" & RootID & " and Child=0 and LinkUrl=''",conn,1,1 do while not rsClass.eof arrClassID=arrClassID & "," & rsClass(0) rsClass.movenext loop end if '取出包括所有子类别记录 Set rsArticle= Server.CreateObject("ADODB.Recordset") sqlArticle="select top "& ArticleNum &" A.ArticleID,A.Title,A.Author,A.TitleFontColor,A.TitleFontType,A.OnTop,A.Elite,A.IncludePic,L.LayoutFileName,A.Hits,A.UpdateTime " sqlArticle=sqlArticle & "from Article A inner join Layout L on A.LayoutID=L.LayoutID " sqlArticle=sqlArticle & "where A.Deleted=False and A.Passed=True and A.ClassID in (" & arrClassID & ")" sqlArticle=sqlArticle & " order by A.OnTop,A.ArticleID desc" rsArticle.open sqlArticle,conn,1,1 if not rsArticle.eof then dim ShowDateType if isInfo then ShowDateType=1 else ShowDateType=0 end if call ArticleContent1(rsArticle,ArticleNum,TitleLen,True,True,isInfo,ShowDateType,isInfo,isInfo) else response.write "·没有任何文章" end if rsArticle.close set rsArticle=nothing else response.write "·没有任何文章" end if rsClass.close set rsClass=nothing end sub '================================================= '过程名:ArticleContent '作 用:显示文章属性、标题、作者、更新日期、点击数等信息 '参 数:intTitleLen -------标题最多字符数,一个汉字=两个英文字符 ' ShowProperty -----是否显示文章属性(固顶/推荐/普通),True为显示,False为不显示 ' ShowIncludePic ---是否显示“[图文]”字样,True为显示,False为不显示 ' ShowAuthor -------是否显示文章作者,True为显示,False为不显示 ' ShowDateType -----显示更新日期的样式,0为不显示,1为显示年月日,2为只显示月日。 ' ShowHits ---------是否显示文章点击数,True为显示,False为不显示 ' ShowHot ----------是否显示热门文章标志,True为显示,False为不显示 '================================================= sub ArticleContent1(rsArticle,ArticleNum,intTitleLen,ShowProperty,ShowIncludePic,ShowAuthor,ShowDateType,ShowHits,ShowHot) '0 A.ArticleID '1 A.Title '2 A.Author '3 A.TitleFontColor '4 A.TitleFontType '5 A.OnTop '6 A.Elite '7 A.IncludePic '8 L.LayoutFileName '9 A.Hits '10 A.UpdateTime dim i,strTemp,TitleStr,Author,AuthorName,AuthorEmail i=0 do while not rsArticle.eof strTemp="" if ShowProperty=True then if rsArticle(5)=true then strTemp = strTemp & " "'"固顶文章 " elseif rsArticle(6)=true then strTemp = strTemp & " "'"推荐文章 " else strTemp = strTemp & " "'"普通文章 " end if end if Author=rsArticle(2) if instr(Author,"|")>0 then AuthorName=left(Author,instr(Author,"|")-1) AuthorEmail=right(Author,len(Author)-instr(Author,"|")-1) else AuthorName=Author AuthorEmail="" end if strTemp = strTemp & "" 'strTemp = strTemp & "' title='文章标题:" & rsArticle(1) & vbcrlf & "作 者:" & AuthorName & vbcrlf & "更新时间:" & rsArticle(10) & vbcrlf & "点击次数:" & rsArticle(9) & "'>" TitleStr=gotTopic(rsArticle(1),intTitleLen) if ShowIncludePic=True and rsArticle(7)=true then TitleStr = "[图文]" & TitleStr end if Select Case rsArticle(4) Case 1 TitleStr="" & TitleStr & "" Case 2 TitleStr="" & TitleStr & "" Case 3 TitleStr="" & TitleStr & "" End Select if rsArticle(3)<>"" then TitleStr="" & TitleStr & "" end if strTemp=strTemp & TitleStr & "" if ShowAuthor=True or ShowDateType>0 or ShowHits=True then strTemp = strTemp & " (" if ShowAuthor=True then if AuthorEmail="" then strTemp=strTemp & AuthorName else strTemp=strTemp & "" & AuthorName & "" end if end if if ShowDateType>0 then if ShowAuthor=True then strTemp=strTemp & "," end if 'if CDate(FormatDateTime(rsArticle(10),2))=date() then ' strTemp = strTemp & "" 'else ' strTemp = strTemp & "" 'end if if ShowDateType=1 then strTemp = strTemp & FormatDateTime(rsArticle(10),1) else strTemp = strTemp & month(rsArticle(10)) & "月" & day(rsArticle(10)) & "日" end if 'strTemp = strTemp & "" end if if ShowHits=True then if ShowAuthor=True or ShowDateType>0 then strTemp=strTemp & "," end if strTemp=strTemp & rsArticle(9) end if strTemp=strTemp & ")" end if if ShowHot=True and rsArticle(9)>=HitsOfHot then strTemp= strTemp & "热点文章" end if strTemp= strTemp & "
    " response.write strTemp rsArticle.movenext i=i+1 if i>=ArticleNum then exit do loop end sub 'class文件名 function ClassFileName(ClassID) dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "select L.LayoutFileName From ArticleClass C inner join Layout L on C.LayoutID=L.LayoutID where C.ClassID=" & ClassID,conn,1,1 if not rsGlobal.eof then ClassFileName = rsGlobal(0) end if rsGlobal.close set rsGlobal = nothing end function 'class路径 function ClassFilePath(ClassID) dim ChannelDir,Repetition dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "SELECT Channel.ChannelDir, ArticleClass.Repetition FROM ArticleClass INNER JOIN Channel ON ArticleClass.ChannelID = Channel.ChannelID WHERE ArticleClass.ClassID=" & ClassID,conn,1,1 if not rsGlobal.eof then ChannelDir = rsGlobal(0) if VarType(rsGlobal(1)) = vbNull then Repetition = "" else Repetition = rsGlobal(1) end if end if rsGlobal.close set rsGlobal = nothing ClassFilePath = InstallDir if ChannelDir <> "" then ClassFilePath = ClassFilePath & ChannelDir & "/" end if 'if UseCreateHTML >= 4 and UseCreateHTML <= 7 then '静态 'else '动态 if Repetition = "" then ClassFilePath = ClassFilePath & ClassFileName(ClassID) & "?ClassID="& ClassID else ClassFilePath = ClassFilePath & Repetition & ".asp" '使用别名 end if 'end if end function 'Article文件名 function ArticleFileName(ArticleID) dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "select L.LayoutFileName From Article A inner join Layout L on A.LayoutID=L.LayoutID where A.ArticleID=" & ArticleID,conn,1,1 if not rsGlobal.eof then ArticleFileName = rsGlobal(0) end if rsGlobal.close set rsGlobal = nothing end function 'Article文件路径 function ArticleFilePath(ArticleID) dim ClassDir,ChannelDir,UseCreateHTML,FileExt_Item dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "SELECT ArticleClass.ClassDir, Channel.ChannelDir, Channel.UseCreateHTML, Channel.FileExt_Item FROM (Article INNER JOIN ArticleClass ON Article.ClassID = ArticleClass.ClassID) INNER JOIN Channel ON ArticleClass.ChannelID = Channel.ChannelID WHERE Article.ArticleID=" & ArticleID,conn,1,1 if not rsGlobal.eof then ClassDir = rsGlobal(0) ChannelDir = rsGlobal(1) UseCreateHTML = rsGlobal(2) FileExt_Item = rsGlobal(3) end if rsGlobal.close set rsGlobal = nothing ArticleFilePath = InstallDir if ChannelDir <> "" then ArticleFilePath = ArticleFilePath & ChannelDir & "/" end if if UseCreateHTML >= 4 and UseCreateHTML <= 7 then '静态 if ClassDir <> "" then ArticleFilePath = ArticleFilePath & ClassDir & "/" end if ArticleFilePath = ArticleFilePath & ArticleID & FileExt_Item else '动态 ArticleFilePath = ArticleFilePath & ArticleFileName(ArticleID) & "?ArticleID="& ArticleID end if end function 'Special文件名 function SpecialFileName(ArticleID) dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "SELECT L.LayoutFileName FROM (Article AS A INNER JOIN Special AS S ON A.SpecialID = S.SpecialID) INNER JOIN Layout AS L ON S.LayoutID = L.LayoutID WHERE A.ArticleID=" & ArticleID,conn,1,1 if not rsGlobal.eof then SpecialFileName = rsGlobal(0) end if rsGlobal.close set rsGlobal = nothing end function 'Special文件路径 function SpecialFilePath(ArticleID) dim ClassDir,ChannelDir,UseCreateHTML,FileExt_Item dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "SELECT ArticleClass.ClassDir, Channel.ChannelDir, Channel.UseCreateHTML, Channel.FileExt_Item FROM (Article INNER JOIN ArticleClass ON Article.ClassID = ArticleClass.ClassID) INNER JOIN Channel ON ArticleClass.ChannelID = Channel.ChannelID WHERE Article.ArticleID=" & ArticleID,conn,1,1 if not rsGlobal.eof then ClassDir = rsGlobal(0) ChannelDir = rsGlobal(1) UseCreateHTML = rsGlobal(2) FileExt_Item = rsGlobal(3) end if rsGlobal.close set rsGlobal = nothing SpecialFilePath = InstallDir if ChannelDir <> "" then SpecialFilePath = SpecialFilePath & ChannelDir & "/" end if if UseCreateHTML >= 5 and UseCreateHTML <= 7 then '静态 if ClassDir <> "" then SpecialFilePath = SpecialFilePath & ClassDir & "/" end if SpecialFilePath = SpecialFilePath & ArticleID & FileExt_Item else '动态 SpecialFilePath = SpecialFilePath & SpecialFileName(ArticleID) & "?ArticleID="& ArticleID end if end function '返回会父类名 function ParentClassName(ClassID) dim TClassID dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "select ParentID,ClassID From ArticleClass where ClassID=" & ClassID,conn,1,1 if not rsGlobal.eof then if rsGlobal("ParentID") > 0 then TClassID = rsGlobal("ParentID") else TClassID = ClassID end if end if rsGlobal.close set rsGlobal = nothing ParentClassName = GetClassName(TClassID) end Function 'class名 function GetClassName(ClassID) dim rsGlobal Set rsGlobal = Server.CreateObject("ADODB.Recordset") rsGlobal.open "select ClassName From ArticleClass where ClassID=" & ClassID,conn,1,1 if not rsGlobal.eof then GetClassName = rsGlobal(0) end if rsGlobal.close set rsGlobal = nothing end function %>