act.main.asp

PDA,若你死昂师傅你说的附件是打开附件上课的附件四度空间就大方快速减肥

	 Function GetIndexNavigation(TitleCss,OpenType,StrNav)'首页导航
		  GetIndexNavigation =  StrNav & "网站首页"
	 End Function


	 Function GetClassNavigation(TitleCss,OpenType,StrNav,ClassID,TypeMode)'栏目
	    Dim ACT_Nav,TypeModeNames
		ACT_Nav=GetClassNav(StrNav, OpenType, TitleCss, ClassID)
		If TypeMode="0" Then TypeModeNames=TypeModeName(TitleCss,OpenType,Application(AcTCMSN & "ModeID"),StrNav)
		If CBool(Application(AcTCMSN & "ModeHome")) = True Then
		  GetClassNavigation =  TypeModeNames&ACT_Nav&StrNav & "首页"
		Else
		  GetClassNavigation =  TypeModeNames&ACT_Nav
		End If
	 End Function


	 Function TypeModeName(TitleCss,OpenType,ModeID,StrNav)
		If modeid="0" Or modeid="" Then Exit Function 
		If ACT_C(ModeID,3)=0 Then 
			TypeModeName="<a "& TitleCss &" href="""&actcmsdm&"Article/Mode.asp?ModeID="&ModeID& """" &OpenType& ">"&ACT_C(ModeID,1)&"系统"&"</a>"&StrNav
		Else 
			TypeModeName="<a "& TitleCss &" href="""&actsys&ACT_C(ModeID,6)&"/""" &OpenType& ">"&ACT_C(ModeID,1)&"系统"&"</a>"&StrNav
		End If 
	 End Function 
	 Function GetContentNavigation(TitleCss,OpenType,StrNav,ClassID,TypeMode)'内容
		Dim ClassNavStr,TypeModeNames:ClassNavStr = GetClassNav(StrNav, OpenType, TitleCss, ClassID)
		If TypeMode="0" Then TypeModeNames=TypeModeName(TitleCss,OpenType,Application(AcTCMSN & "ModeID"),StrNav)
		GetContentNavigation =   TypeModeNames&ClassNavStr & StrNav & "浏览正文"
	 End Function

	Function GetClassNavStr(ClassID)
		Dim ClassRS
		Set ClassRS=actexe("Select ParentID,ClassID,Classname from class_ACT where ClassID='"& ClassID &"' order by ID desc")
		If Not ClassRs.eof Then 
			If ClassRS("ParentID")<>"0" Then
				GetClassNavStr = GetClassNavStr(ClassRS("ParentID")) &GetClassNavStr
			End If 
		End if
		GetClassNavStr=GetClassNavStr&ClassID&" , "
		ClassRS.Close:Set ClassRS = Nothing
	End function

	Function GetClassNav(StrNav,OpenType, TitleCss, ClassID)
	  Dim TSArr,i,Q
	  ClassID=GetClassNavStr(ClassID)
	  ClassID=Left(Trim(ClassID), Len(Trim(ClassID)) - 1)
	  TSArr = Split(ClassID, ",")
	  For I = 0 To UBound(TSArr)
		If i>0 Then Q=StrNav
		GetClassNav = GetClassNav & Q &"<a "& TitleCss &" href=""" & GetSubClasseName(Trim(TSArr(I))) & """" &OpenType& ">" & ACT_L(Trim(TSArr(I)), 2) & "</a>"
	  Next
	End Function 
   



	Function TempClassID(ClassID)
	If ClassID = "" Then Exit Function
	Dim Rs,AllClassID
	Set Rs = Conn.ExeCute("Select ClassID From Class_Act Where ParentID = '"&ClassID&"' Order By OrderID Desc,ID Desc") 
	If Rs.Eof Then
		AllClassID = "'" & ClassID & "'"
	Else
		AllClassID = ""
		Do While Not Rs.Eof
			AllClassID = AllClassID & "," & TempClassID(Rs(0))
			Rs.MoveNext
		Loop
		AllClassID = "'" & ClassID & "'" & AllClassID
	End If
	TempClassID = AllClassID
	Rs.Close:Set Rs = Nothing
	End Function



	Public Function ActErr(ShowErr,ErrNum)
		Response.Redirect(ActSys&ActCMS_Sys(8)&"/Error.asp?Errs="&Server.URLEncode("<li>"&ShowErr&"</li>")&"&Title="&ErrNum&"")
		Response.end
	End Function 


	Public Function GroupArr(GroupID,Row)

		  Dim Rs
		  Set Rs=ACTEXE("Select ModeID,GroupSetting from Group_Act  Where GroupID=" & GroupID & " order by GroupID desc")
		  If Not Rs.Eof Then
				GroupArr=Split(Rs("GroupSetting"),"^@$@^")(Row)
		  End If 

	End Function 
	Public Sub isAcceptOK(ModeID,GroupID,UserName,InfoTitle)
	    IF Not IsNumeric(ModeID) Then Exit Sub
	    IF  GroupID=0 Then Exit Sub
	    Dim RSAccept,Tgdianshu:Set RSAccept=Server.CreateObject("ADODB.RECORDSET")
			RSAccept.Open "Select Score,GroupID From "&CheckUserMode(GroupID)&" Where UserName='" & UserName & "'",Conn,1,3
				IF Not RSAccept.Eof Then
					Tgdianshu=RSAccept(0)+GroupArr(RSAccept("GroupID"),15)
					If Tgdianshu="0" Or Tgdianshu="" Then Tgdianshu=0
					RSAccept(0)=Tgdianshu
					RSAccept.Update
					Dim Sender:Sender=ActCMS_Sys(0)
					Dim Title:Title="恭喜，您发表的稿件[" & InfoTitle & "]已被审核通过！！！"
					Dim Message:Message="稿件标题：" & InfoTitle &""_
					  & "获得点数：" & GroupArr(RSAccept("GroupID"),15) & ""_
					  & "备注：此信息由系统自动发布，请不要回复！！！"
					Call PointUpdate(ModeID,0,UserName,1,Tgdianshu,"系统","发表搞件[" & InfoTitle & "]所得")  '记录日志          
					Call SendInfo(UserName,Sender,Title,Message)
					ACTEXE("Update "&CheckUserMode(GroupID)&" Set ArticleNum=ArticleNum+1 Where UserName='" & UserName & "'")'暂放

			End IF
		RSAccept.Close:Set RSAccept=Nothing
	End Sub


	Public Function CheckUserMode(GroupID)
		Dim Ruser,rs1,UserModeID
		Set Ruser=actexe("Select ModeID from Group_Act where GroupID="&GroupID&"")
		If Not Ruser.eof Then UserModeID=Ruser("ModeID"):Ruser.Close:Set Ruser=Nothing
		 Set Rs1=actexe("select ModeTable from ModeUser_Act where ModeID="&UserModeID&" ")
		 If Not Rs1.eof Then
			CheckUserMode=Rs1("ModeTable")
			Rs1.Close:Set Rs1=Nothing
		 End if	
	End Function 

	Public Function PointUpdate(ModeID,ID,UserName,PointFlag,Point,User,Descript)
	  Dim RsPoint:Set RsPoint=Server.CreateObject("Adodb.Recordset")
	  RsPoint.Open "Select * From Point_Log_ACT Where ID is null",Conn,1,3
	   RsPoint.AddNew
	     RsPoint("ModeID")=ModeID
		 RsPoint("ID")=ID
		 RsPoint("UserName")=UserName
		 RsPoint("PointFlag")=PointFlag
		 RsPoint("Point")=Point
		 RsPoint("Times")=1
		 RsPoint("User")=User
		 RsPoint("Descript")=Descript
		 RsPoint("AddDate")=now
		 RsPoint("IP")=Request.ServerVariables("Remote_Addr")
	   RsPoint.Update
	  RsPoint.Close:Set RsPoint=Nothing
	End Function

	Public Sub SendInfo(Incept,Sender,title,Content)
	  ActExe("insert Into Message_Act(Incept,Sender,Title,Content,SendTime,Flag,IsSend,DelR,DelS) values('" & Incept & "','" & Sender & "','" & replace(Title,"'","""") & "','" & replace(Content,"'","""") & "'," & NowString & ",0,1,0,0)")
	End Sub

	'Folder要创建的目录
	 Function CreateFolder(Folder)
		Dim FSO,  SplitFolder, CF, k
		on error resume next
		If Folder = "" Then
		 CreateFolder = False:Exit Function
		End If
	   Folder = Replace(Folder, "\", "/")
	   If Right(Folder, 1) <> "/" Then
		Folder = Folder & "/"
	   End If
	   If Left(Folder, 1) <> "/" Then
		Folder = "/" & Folder
		End If
		 Set FSO = CreateObject("scripting.filesystemobject")
		 If Not FSO.FolderExists(Server.MapPath(Folder)) Then
		   SplitFolder = Split(Folder, "/")
		 For k = 0 To UBound(SplitFolder) - 1
		  If k = 0 Then
		   CF = SplitFolder(k) & "/"
		  Else
		  CF = CF & SplitFolder(k) & "/"
		  End If
		  If (Not FSO.FolderExists(Server.MapPath(CF))) Then
			 FSO.CreateFolder (Server.MapPath(CF))
			 CreateFolder = True
		  End If
		 Next
	   End If
	   Set FSO = Nothing
	   If Err.Number <> 0 Then
	   Err.Clear
	   CreateFolder = False
	   Else
	   CreateFolder = True
	   End If
	 End Function

	Public Function DeleteFile(FileStr)'FSO删除
	   Dim FSO
	   on error resume next
	   Set FSO = CreateObject("scripting.FileSystemObject")
		If FSO.FileExists(Server.MapPath(FileStr)) Then
			FSO.DeleteFile Server.MapPath(FileStr), True
		Else
		DeleteFile = True
		End If
	   Set FSO = Nothing
	   If Err.Number <> 0 Then
	   Err.Clear:DeleteFile = False
	   Else
	   DeleteFile = True
	   End If
	End Function

	Public Function ACT_ATT(Selected)
		 Dim RSObj
	    Set RSObj = ACTExe("Select AID,Aname From ATT_ACT")
	  	Do While Not RSObj.Eof
		   IF Selected=RSObj(0) Then
			ACT_ATT=ACT_ATT & "<option value=""" & RSObj(0) & """ Selected>" & RSObj(1) & "</option>"& vbCrLf
		   Else
			ACT_ATT=ACT_ATT & "<option value=""" & RSObj(0) & """>" & RSObj(1) & "</option>"& vbCrLf
		   End If
		RSObj.MoveNext
		Loop
	  RSObj.Close:Set RSObj=Nothing
	End Function	

	Public Function ReplaceUrl(ReplaceContent, SaveFilePath)
		Dim re, BeyondFile, BFU, SaveFileName, SysDomain
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|png|bmp)))"
		Set BeyondFile = re.Execute(ReplaceContent)
		Set re = Nothing
		For Each BFU In BeyondFile
			SaveFileName = Year(Now()) & Month(Now()) & Day(Now()) & MakeRandom(10) & Mid(BFU, InStrRev(BFU, "."))
			 Call SaveFile(SaveFilePath&SaveFileName,BFU)
			ReplaceContent = Replace(ReplaceContent, BFU,  SaveFilePath & SaveFileName)
		Next
		ReplaceUrl = ReplaceContent
	End Function
	
	Function SaveFile(LocalFileName,RemoteFileUrl)
	    on error resume next
		Dim SaveRemoteFile:SaveRemoteFile=True
		dim Ads,Retrieval,GetRemoteData
		Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
		With Retrieval
			.Open "Get", RemoteFileUrl, False, "", ""
			.Send
			If .Readystate<>4 then
				SaveRemoteFile=False
				Exit Function
			End If
			GetRemoteData = .ResponseBody
		End With
		Set Retrieval = Nothing
		Set Ads = Server.CreateObject("Adodb.Stream")
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile server.MapPath(LocalFileName),2
			.Cancel()
			.Close()
		End With
		Set Ads=nothing
		SaveFile=SaveRemoteFile
		Dim W:Set W=New Watermark
		Call W.AddWaterMark(LocalFileName)
		Set W=Nothing
	End Function
	
	'生成指定位数的随机数
	Public Function MakeRandom(ByVal maxLen)
	  Dim strNewPass,whatsNext, upper, lower, intCounter
	  Randomize
	 For intCounter = 1 To maxLen
	   upper = 57:lower = 48:strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + lower))
	 Next
	   MakeRandom = strNewPass
	End Function


	'**************************************************
	'函数名：strLength
	'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
	'参  数：str  ----要求长度的字符串
	'返回值：字符串长度
	'**************************************************
	Public Function strLength(Str)
		On Error Resume Next
		Dim WINNT_CHINESE:WINNT_CHINESE = (Len("中国") = 2)
		If WINNT_CHINESE Then
			Dim l, T, c,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




   Public Function GetStrValue(ByVal strs, ByVal strlen)
		If strs = "" Then GetStrValue = "":Exit Function
		If strlen=0 Then GetStrValue=strs:Exit Function
		Dim l, T, c, I, strTemp
		Dim str
		str=ACTCMS.CloseHtml(strs)
		l = Len(Str)
		T = 0
		strTemp = Str
		strlen = CLng(strlen)
		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
				strTemp = Left(Str, I)
				Exit For
			End If
		Next
		If strTemp <> Str Then	strTemp = strTemp
		GetStrValue=Replace(strs,str,strTemp)
  End Function


	Public Function HTMLCode(fString)
		If Not IsNull(fString) then
		fString = replace(fString, "&gt;", ">")
		fString = replace(fString, "&lt;", "<")
		fString = Replace(fString,  "&nbsp;"," ")
		fString = Replace(fString, "&quot;", CHR(34))
		fString = Replace(fString, "&#39;", CHR(39))
		fString = Replace(fString, "</P><P> ",CHR(10) & CHR(10))
		fString = Replace(fString, "<BR> ", CHR(10))
		HTMLCode = fString
		End If
	End Function
	Public Function HTMLEncode(fString)
		If Not IsNull(fString) then
		fString = replace(fString, ">", "&gt;")
		fString = replace(fString, "<", "&lt;")
		fString = replace(fString, "&", "&amp;")
		fString = Replace(fString, CHR(32), "&nbsp;")
		fString = Replace(fString, CHR(9), "&nbsp;")
		fString = Replace(fString, CHR(34), "&quot;")
		fString = Replace(fString, CHR(39), "&#39;")
		fString = Replace(fString, CHR(13), "")
		fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
		fString = Replace(fString, CHR(10), "<BR> ")
		HTMLEncode = fString
		End If
	End Function

	Public Function CloseHtml(ContentStr)
		Dim TempLoseStr, regEx
		If ContentStr="" Then Exit Function
		TempLoseStr = CStr(ContentStr)
		Set regEx = New RegExp
		regEx.Pattern = "<\/*[^<>]*>"
		regEx.IgnoreCase = True
		regEx.Global = True
		TempLoseStr = regEx.Replace(TempLoseStr, "")
		CloseHtml = TempLoseStr
	End Function

		Function DelSql(Str)
			Dim SplitSqlStr,SplitSqlArr,I
			SplitSqlStr="*|and |exec |insert |select |delete |update |count |master |truncate |declare |and	|exec	|insert	|select	|delete	|update	|count	|master	|truncate	|declare	|char(|mid(|chr("
			SplitSqlArr = Split(SplitSqlStr,"|")
			For I=LBound(SplitSqlArr) To Ubound(SplitSqlArr)
				If Instr(LCase(Str),SplitSqlArr(I))<>0 Then
					Call Alert ("系统警告！\n\n1、您提交的数据有恶意字符;\n2、您的数据已经被记录;\n3、操作日期："&Now&";\n		Powered By ActCMS.Com!","")
					Response.End
				End if
			Next
			DelSql = Str
		End Function


		Public Function S(Str)
		 S = DelSql(Replace(Replace(Request(Str), "'", ""), """", ""))
		End Function
		Public Function G(Str)
		 G = Replace(Replace(Request(Str), "'", ""), """", "")
		End Function

		Public Function Alert(SuccessStr, Url)
		 If Url <> "" Then
		  Response.Write ("<script language=""Javascript""> alert('" & SuccessStr & "');location.href='" & Url & "';</script>")
		 Else
		  Response.Write ("<script language=""Javascript""> alert('" & SuccessStr & "');history.back(-1);</script>")
		 End If
		 response.end
		End Function

	
		Public Function ShowPagePara(totalnumber, MaxPerPage, FileName, ShowAllPages, strUnit, CurrentPage, ParamterStr)
				 Dim N, I, PageStr
				Const Btn_First = "<font face='webdings' size='1' title='第一页'>9</font>" '定义第一页按钮显示样式
				Const Btn_Prev = "<font face='webdings' size='1' title='上一页'>3</font>" '定义前一页按钮显示样式
				Const Btn_Next = "<font face='webdings' size='1' title='下一页'>4</font>" '定义下一页按钮显示样式
				Const Btn_Last = "<font face='webdings' size='1' title='最后一页'>:</font>" '定义最后一页按钮显示样式
				  PageStr = ""
					If totalnumber Mod MaxPerPage = 0 Then
						N = totalnumber \ MaxPerPage
					Else
						N = totalnumber \ MaxPerPage + 1
					End If
				If N > 1 Then
					PageStr = PageStr & ("页次：<font color=red>" & CurrentPage & "</font>/" & N & "页 共有:" & totalnumber & strUnit & " 每页:" & MaxPerPage & strUnit & " ")
					If CurrentPage < 2 Then
						PageStr = PageStr & Btn_First & " " & Btn_Prev & " "
					Else
						PageStr = PageStr & ("<a href=" & FileName & "?page=1" & "&" & ParamterStr & ">" & Btn_First & "</a> <a href=" & FileName & "?page=" & CurrentPage - 1 & "&" & ParamterStr & ">" & Btn_Prev & "</a> ")
					End If
					
					If N - CurrentPage < 1 Then
						PageStr = PageStr & " " & Btn_Next & " " & Btn_Last & " "
					Else
						PageStr = PageStr & (" <a href=" & FileName & "?page=" & (CurrentPage + 1) & "&" & ParamterStr & ">" & Btn_Next & "</a> <a href=" & FileName & "?page=" & N & "&" & ParamterStr & ">" & Btn_Last & "</a> ")