harry.asp

为我们公司使用的oa系统

         		dim bookmark
           		bookmark=rsArticle.bookmark
            	call ArticleContent(TitleLen,True,True,False,2,False,True)
        	else
	        	currentPage=1
           		call ArticleContent(TitleLen,True,True,False,2,False,True)
	    	end if
		end if
	end if
	rsArticle.close
	set rsArticle=nothing
end sub

sub ArticleContent(intTitleLen,ShowProperty,ShowIncludePic,ShowAuthor,ShowDateType,ShowHits,ShowHot)
   	dim i,strTemp,TitleStr,Author,AuthorName,AuthorEmail
    i=0
	do while not rsArticle.eof
		strTemp=""
		if ShowProperty=True then
			if rsArticle("OnTop")=true then
				strTemp = strTemp & "&nbsp;&nbsp;<img src='images/article_ontop.gif' alt='固顶文章'>&nbsp;"
			elseif rsArticle("Elite")=true then
				strTemp = strTemp & "&nbsp;&nbsp;<img src='images/article_elite.gif' alt='推荐文章'>&nbsp;"
			else
				strTemp = strTemp & "&nbsp;&nbsp;<img src='images/article_common.gif' alt='普通文章'>&nbsp;"
			end if
		end if
		if ShowIncludePic=True and rsArticle("IncludePic")=true then
			strTemp = strTemp & "<font color=blue>[图文]</font>"
		end if
		Author=rsArticle("Author")
		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
		http=rsArticle("http")
		if http<>"http://" then
		strTemp = strTemp & "<a href='" & rsArticle("http") & "' target='_blank'>"
		TitleStr=gotTopic(rsArticle("title"),intTitleLen)
		if rsArticle("TitleFontType")=1 then
			TitleStr="<b>" & TitleStr & "</b>"
		elseif rsArticle("TitleFontType")=2 then
			TitleStr="<em>" & TitleStr & "</em>"
		elseif rsArticle("TitleFontType")=3 then
			TitleStr="<b><em>" & TitleStr & "</em></b>"
		end if
		if rsArticle("TitleFontColor")<>"" then
			TitleStr="<font color='" & rsArticle("TitleFontColor") & "'>" & TitleStr & "</font>"
		end if
		strTemp=strTemp & TitleStr & "</a>"
		else
		strTemp = strTemp & "<a href='" & rsArticle("LayoutFileName") & "?ArticleID=" & rsArticle("articleid") & "' title='文章标题：" & rsArticle("Title") & vbcrlf & "作    者：" & AuthorName & vbcrlf & "更新时间：" & rsArticle("UpdateTime") & vbcrlf & "点击次数：" & rsArticle("Hits") & "' target='_blank'>"
		TitleStr=gotTopic(rsArticle("title"),intTitleLen)
		if rsArticle("TitleFontType")=1 then
			TitleStr="<b>" & TitleStr & "</b>"
		elseif rsArticle("TitleFontType")=2 then
			TitleStr="<em>" & TitleStr & "</em>"
		elseif rsArticle("TitleFontType")=3 then
			TitleStr="<b><em>" & TitleStr & "</em></b>"
		end if
		if rsArticle("TitleFontColor")<>"" then
			TitleStr="<font color='" & rsArticle("TitleFontColor") & "'>" & TitleStr & "</font>"
		end if
		strTemp=strTemp & TitleStr & "</a>"
		end if
		if ShowAuthor=True or ShowDateType>0 or ShowHits=True then
			strTemp = strTemp & "&nbsp;("
			if ShowAuthor=True then
				if AuthorEmail="" then
					strTemp=strTemp & AuthorName
				else
					strTemp=strTemp & "<a href='mailto:" & AuthorEmail & "'>" & AuthorName & "</a>"
				end if
			end if
			if ShowDateType>0 then
				if ShowAuthor=True then
					strTemp=strTemp & "，"
				end if
				if CDate(FormatDateTime(rsArticle("UpdateTime"),2))=date() then
					strTemp = strTemp & "<font color=red>"
				else
					strTemp= strTemp & "<font color=#999999>"
				end if
				if ShowDateType=1 then
					strTemp= strTemp & month(rsArticle("UpdateTime")) & "月" & day(rsArticle("UpdateTime")) & "日</font>"
				else
					strTemp=strTemp & FormatDateTime(rsArticle("UpdateTime"),1) & "</font>"
				end if
			end if
			if ShowHits=True then
				if ShowAuthor=True or ShowDateType>0 then
					strTemp=strTemp & "，"
				end if
				strTemp=strTemp & rsArticle("Hits")
			end if
			strTemp=strTemp  & ")"
		end if
		if ShowHot=True and rsArticle("Hits")>=HitsOfHot then
			strTemp= strTemp & "<img src='images/hot.gif' alt='热点文章'>"
		end if
		strTemp= strTemp & "<br>"
		response.write strTemp
		rsArticle.movenext
		i=i+1
		if i>=MaxPerPage then exit do	
	loop
end sub 

sub ShowPicArticle(intClassID,ArticleNum,TitleLen,ShowType,Cols,ImgWidth,ImgHeight,ContentLen,Hot,Elite)
	dim sqlPic,i,tClass,trs,arrClassID
	if ArticleNum<0 or ArticleNum>=50 then
		ArticleNum=5
	end if
	if ShowType<>1 and ShowType<>2 then
		ShowType=1
	end if
	if Cols<=0 or Cols>=10 then
		Cols=5
	end if
	if ImgWidth<0 or ImgWidth>500 then
		ImgWidth=150
	end if
	if ImgHeight<0 or ImgHeight>500 then
		ImgHeight=150
	end if
	if Hot<>True and Hot<>False then
		Hot=False
	end if
	if Elite<>True and Elite<>False then
		Elite=False
	end if

	sqlPic="select top " & ArticleNum
	sqlPic=sqlPic & " A.ArticleID,A.ClassID,L.LayoutID,L.LayoutFileName,A.Title,A.Keywords,A.Author,A.CopyFrom,A.UpdateTime,A.Editor,A.TitleFontColor,A.TitleFontType,"
	if ShowType=2 then
		sqlPic=sqlPic & "A.Content,"
	end if
	sqlPic=sqlPic & " A.Hits,A.OnTop,A.Hot,A.Elite,A.Passed,A.IncludePic,A.Stars,A.PaginationType,A.ReadLevel,A.ReadPoint,A.DefaultPicUrl from Article A"
	sqlPic=sqlPic & " inner join Layout L on A.LayoutID=L.LayoutID where A.Deleted=0 and A.Passed=1 and DefaultPicUrl<>''"

	if intClassID>0 then
		set tClass=conn.execute("select ClassID,Child,ParentPath from ArticleClass where ClassID=" & intClassID)
		if not(tClass.bof and tClass.eof) then
			if tClass(1)>0 then
				arrClassID=ClassID
				set trs=conn.execute("select ClassID from ArticleClass where ParentID=" & tClass(0) & " or ParentPath like '%" & tClass(2) & "," & tClass(0) & ",%' and Child=0 and LinkUrl=''")
				do while not trs.eof
					arrClassID=arrClassID & "," & trs(0)
					trs.movenext
				loop
				set trs=nothing	
				sqlPic=sqlPic & " and A.ClassID in (" & arrClassID & ")"
			else
				sqlPic=sqlPic & " and A.ClassID=" & tClass(0)
			end if
			set trs=nothing
		else
			sqlPic=sqlPic & " and A.ClassID=" & tClass(0)
		end if
		set tClass=nothing
	end if
	if Hot=True then
		sqlPic=sqlPic & " and A.Hits>=" & HitsOfHot
	end if
	if Elite=True then
		sqlPic=sqlPic & " and A.Elite=1 "
	end if
	sqlPic=sqlPic & " order by A.OnTop,A.ArticleID desc"
	set rsPic=Server.CreateObject("ADODB.Recordset")
	rsPic.open sqlPic,conn,1,1
	strPic= "<table cellpadding='0' cellspacing='5' border='0'><tr valign='top'>"
	if rsPic.bof and rsPic.eof then
		strPic= strPic & "<td align='center'><img src='images/NoPic.jpg' width='" & ImgWidth & "' height='" & ImgHeight & "' border='0'><br>没有任何图片文章</td>"
	else
		i=0
		if ShowType=1 then
			do while not rsPic.eof
				strPic=strPic & "<td align='center'>"
				call GetPicArticleTitle(TitleLen,ImgWidth,ImgHeight)
				strPic=strPic & "</td>"
				rsPic.movenext
				i=i+1
				if ((i mod Cols=0) and (not rsPic.eof)) then strPic=strPic & "</tr><tr valign='top'>"
			loop
		elseif ShowType=2 then
			do while not rsPic.eof
				strPic=strPic & "<td align='center'>"
				call GetPicArticleTitle(TitleLen,ImgWidth,ImgHeight)
				strPic=strPic & "</td><td valign='top' algin='center' class='left'><a href='" & rsPic("LayoutFileName") & "?ArticleID=" & rsPic("ArticleID") & "'>" & left(nohtml(rsPic("Content")),ContentLen) & "……</a></td>"
				rsPic.movenext
				i=i+1
				if ((i mod Cols=0) and (not rsPic.eof)) then strPic=strPic & "</tr><tr valign='top'>"
			loop
		end if
		
	end if
	strPic=strPic &  "</tr></table>"
	response.write strPic
	rsPic.close
end sub

sub GetPicArticleTitle(intTitleLen,intImgWidth,intImgHeight)
	dim FileType,TitleStr
	FileType=right(lcase(rsPic("DefaultPicUrl")),3)
	TitleStr=gotTopic(rsPic("Title"),intTitleLen)
	strPic=strPic & "<a href='" & rsPic("LayoutFileName") & "?ArticleID=" & rsPic("ArticleID") & "' title='文章标题：" & rsPic("Title") & vbcrlf & "作    者：" & rsPic("Author") & vbcrlf & "更新时间：" & rsPic("UpdateTime") & vbcrlf & "点击次数：" & rsPic("Hits") & "' target='_blank'>"
	if FileType="swf" then
		strPic=strPic & "<object classid='clsid:D27CDB6E-AE6D-11cf-96B8-444553540000' codebase='http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=5,0,0,0' width='" & intImgWidth & "' height='" & intImgHeight & "'><param name='movie' value='" & rsPic("DefaultPicUrl") & "'><param name='quality' value='high'><embed src='" & rsPic("DefaultPicUrl") & "' pluginspage='http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash' type='application/x-shockwave-flash' width='" & intImgWidth & "' height='" & intImgHeight & "'></embed></object>"
	elseif fileType="jpg" or fileType="bmp" or fileType="png" or fileType="gif" then
		strPic=strPic & "<img src='" & rsPic("DefaultPicUrl") & "' width='" & intImgWidth & "' height='" & intImgHeight & "' border='0'>"
	else
		strPic=strPic & "<img src='images/NoPic2.jpg' width='" & intImgWidth & "' height='" & intImgHeight & "' border='0'>"
	end if
	if rsPic("TitleFontType")=1 then
		TitleStr="<b>" & TitleStr & "</b>"
	elseif rsPic("TitleFontType")=2 then
		TitleStr="<em>" & TitleStr & "</em>"
	elseif rsPic("TitleFontType")=3 then
		TitleStr="<b><em>" & TitleStr & "</em></b>"
	end if
	if rsPic("TitleFontColor")<>"" then
		TitleStr="<font color='" & rsPic("TitleFontColor") & "'>" & TitleStr & "</font>"
	end if
	strPic=strPic & "<br>" & TitleStr & "</a>"
end sub


sub ShowArticleContent()
	if rs("ReadLevel")<=999 then
		if UserLogined<>True then 
			FoundErr=True
			ErrMsg=ErrMsg & "<br>&nbsp;&nbsp;&nbsp;&nbsp;你还没注册？或者没有登录？这篇文章要求至少是本站的注册用户才能阅读！<br><br>"
			ErrMsg=ErrMsg & "&nbsp;&nbsp;&nbsp;&nbsp;如果你还没注册，请赶紧<a href='User_Reg.asp'><font color=red>点此注册</font></a>吧！<br><br>"
			ErrMsg=ErrMsg & "&nbsp;&nbsp;&nbsp;&nbsp;如果你已经注册但还没登录，请赶紧<a href='User_Login.asp'><font color=red>点此登录</font></a>吧！<br><br>"
		else
			if UserLevel>rs("ReadLevel") then
				FoundErr=True
				ErrMsg=ErrMsg & "<p align='center'><br><br><font color=red><b>对不起，你的权限不够，不能阅读此文章!</b></font></p>"
			else
				if ChargeType=1 and rs("ReadPoint")>0 then
					if Request.Cookies("asp163")("Pay_Article" & ArticleID)<>"yes" then
						if UserPoint<rs("ReadPoint") then
							FoundErr=True
							ErrMsg=ErrMsg &"<p align='center'><br><br>对不起，阅读本文需要消耗 <b><font color=red>" & rs("ReadPoint") & "</font></b> 点！"
							ErrMsg=ErrMsg &"而你目前只有 <b><font color=blue>" & UserPoint & "</font></b> 点可用。点数不足，无法阅读本文。请与我们联系进行充值。</p>"
						else
							if lcase(trim(request("Pay")))="yes" then
								Conn_User.execute "update " & db_User_Table & " set " & db_User_UserPoint & "=" & db_User_UserPoint & "-" & rs("ReadPoint") & " where " & db_User_Name & "='" & UserName & "'"
								response.Cookies("asp163")("Pay_Article" & ArticleID)="yes"
							else
								FoundErr=True
								ErrMsg=ErrMsg &"<p align='center'><br><br>阅读本文需要消耗 <b><font color=red>" & rs("ReadPoint") & "</font></b> 点！"
								ErrMsg=ErrMsg &"你目前尚有 <b><font color=blue>" & UserPoint & "</font></b> 点可用。阅读本文后，你将剩下 <b><font color=green>" & UserPoint-rs("ReadPoint") & "</font></b> 点"
								ErrMsg=ErrMsg &"<br><br>你确实愿意花费 <b><font color=red>" & rs("ReadPoint") & "</font></b> 点来阅读本文吗？"
								ErrMsg=ErrMsg &"<br><br><a href='"& strFileName & "?Pay=yes&ArticleID=" & ArticleID & "'>我愿意</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<a href='index.asp'>我不愿意</a></p>"
							end if
						end if
					end if
				elseif ChargeType=2 then
					if ValidDays<=0 then
						FoundErr=True
						ErrMsg=ErrMsg & "<p align='center'><br><br><font color=red>对不起，本文为收费内容，而您的有效期已经过期，所以无法阅读本文。请与我们联系进行充值。</font></p>"
					end if
				end if
			end if
		end if
	end if

	if FoundErr=True then
		ErrMsg="<p align=left><b>内容预览：</b><br><br>" & left(nohtml(rs("Content")),300) & "……</p>" & ErrMsg
		response.write ErrMsg
		exit sub
	end if
	
	dim PaginationType
	PaginationType=rs("PaginationType")
	select case PaginationType
		case 0    '不分页显示
			response.write rs("Content")
		case 1    '自动分页显示
			call AutoPagination()
		case 2    '手动分页显示
			call ManualPagination()
	end select
end sub
%>