act.main.asp

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

<%
Class ACT_Main
	Private LocalCacheName, Cache_Data,CacheData
	Public Reloadtime
	Public ActCMS_Sys,ActCMS_User,ActCMS_Other

	Private Sub Class_Initialize()
		Reloadtime = 28800
		Call GetConfig()
		ActCMS_Sys=Split(CacheData(0,0),"^@$@^")
		ActCMS_Other=Split(CacheData(1,0),"^@&@^")
	End Sub
	Private Sub Class_Terminate()
		If IsObject(Conn) Then Conn.Close : Set Conn = Nothing
		Call CloseConn()
	End Sub

	Public Function ACTExe(Command)
		If Not IsObject(Conn) Then ConnectionDatabase	
			on error resume next
			Set ACTExe = Conn.Execute(Command)
			If Err Then
				err.Clear
				Set Conn = Nothing
				Response.Write "<li>查询数据的时候发现错误，请检查您的查询代码是否正确。<br /><li>"
				Response.Write Command
				Response.End
			End If
	 End Function


	Public Property Let Name(ByVal vNewValue)
		LocalCacheName = LCase(vNewValue)
		Cache_Data = Application(AcTCMSN & "_" & LocalCacheName)
	End Property
	Public Property Let Value(ByVal vNewValue)
		If LocalCacheName <> "" Then
			ReDim Cache_Data(2)
			Cache_Data(0) = vNewValue
			Cache_Data(1) = Now()
			Application.Lock
			Application(AcTCMSN & "_" & LocalCacheName) = Cache_Data
			Application.UnLock
		End If
	End Property
	Public Property Get Value()
		If LocalCacheName <> "" Then
			If IsArray(Cache_Data) Then
				Value = Cache_Data(0)
			End If
		End If
	End Property
	Public Function ObjIsEmpty()
		ObjIsEmpty = True
		If Not IsArray(Cache_Data) Then Exit Function
		If Not IsDate(Cache_Data(1)) Then Exit Function
		If DateDiff("s", CDate(Cache_Data(1)), Now()) < (60 * Reloadtime) Then ObjIsEmpty = False
	End Function
	Public Sub DelCahe(MyCaheName)
		Application.Lock
		Application.Contents.Remove (MyCaheName)
		Application.UnLock
	End Sub


	Public Function GetConfig()'第一次起用系统或者重启IIS的时候加载缓存
		Name = "Config"
		If ObjIsEmpty() Then ReloadConfig
		CacheData = Value
		Name = "Date"
		If ObjIsEmpty() Then
			Value = Date
		Else
			If CStr(Value) <> CStr(Date) Then
				Name = "Config"
				Call ReloadConfig
				CacheData = Value
			End If
		End If
		If Len(CacheData(1, 0)) = 0 Then
			Name = "Config"
			Call ReloadConfig
			CacheData = value
		End If
		End Function

	    Public Sub ReloadConfig()
		   Dim RS
		   Set Rs = ACTExe("SELECT  Top 1 ActCMS_SysSetting,ActCMS_OtherSetting,ActCMS_WatermarkSetting  from [Config_act]")
		   value=RS.GetRows(1)
		   Set RS=Nothing
		End Sub
		

	Public Function GetRandomize(CMS_number)'随机字符串
		Randomize
		Dim CMS_Randchar,CMS_Randchararr,CMS_RandLen,CMS_Randomizecode,CMS_iR
		CMS_Randchar="0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
		CMS_Randchararr=split(CMS_Randchar,",") 
		CMS_RandLen=CMS_number 
		For CMS_iR=1 to CMS_RandLen
			CMS_Randomizecode=CMS_Randomizecode&CMS_Randchararr(Int((21*Rnd)))
		Next 
		GetRandomize = CMS_Randomizecode
	End Function

   Public Function Chkchars(Chars)'检测英文名称是否合法
		Dim Charname, i, c
		Charname = Chars
		Chkchars = True
		If Len(Charname) <= 0 Then
			Chkchars = False
			Exit Function
		End If
		For i = 1 To Len(Charname)
		   C = Mid(Charname, i, 1)
			If InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ@,.0123456789|-_", c) <= 0  Then
			   Chkchars = False
			Exit Function
		   End If
	   Next
	End Function

	Public Function ActCMSDM()
	   ActCMSDM = Trim(ActCMS_Sys(2) & ActCMS_Sys(3))
	End Function

	Public Function ActSys()
	   ActSys = Trim(ActCMS_Sys(3))
	End Function


	 Public Function SysCount(ModeID)'统计模型文章总数
		Dim CountValue
	    Name="SysCount"&ModeID
	    If ObjIsEmpty() Then 
			Set CountValue=ACTEXE("Select Count(id)  From "&ACTCMS.ACT_C(ModeID,2)&"")
			If Not CountValue.eof Then 
				Value=CountValue(0)
				SysCount=CountValue(0)
				CountValue.close:set CountValue=nothing
			End If 
		Else
			SysCount=Value
		End If 
	 End Function 

	 Public Function TodayRenewal(ModeID)'统计模型文章今日更新
	   Dim TodayValue
		Set TodayValue=ACTEXE("Select Count(id)  From "&ACTCMS.ACT_C(ModeID,2)&" where DateDiff('d',UpdateTime," & NowString & ")=0")
		If Not TodayValue.eof Then  
			TodayRenewal=TodayValue(0)
			TodayValue.close:set TodayValue=nothing
		End If 
	 End Function 

	 Public Function CountClass(ClassID)'统计模型文章今日更新
	   Dim ClassValue
	   Name="CountClass"&ClassID
	   If ObjIsEmpty() Then 
			Set ClassValue=ACTEXE("Select Count(id)  From "&ACTCMS.ACT_C(ACT_L(ClassID,10),2)&" where classid='"&ClassID&"'")
			If Not ClassValue.eof Then 
				Value=ClassValue(0)
				CountClass=ClassValue(0)
				ClassValue.close:set ClassValue=nothing
			End If 
		Else
			CountClass=Value
		End If 
	 End Function 

	Public Function ChkAdmin()'检测是否超级管理员
		ChkAdmin = False
		If Request.Cookies(AcTCMSN)("AdminName") = "" Then
			ChkAdmin = False
			Exit Function
		ElseIf Request.Cookies(AcTCMSN)("SuperTF") = "1" Then 
			ChkAdmin = True
			Exit Function
		End If 
	End Function 


	Public Function ACTCMS_QXYZ(ModeID,QXLX,ClassID)'权限验证
			ACTCMS_QXYZ = False
		If Request.Cookies(AcTCMSN)("AdminName") = "" Then
			ACTCMS_QXYZ = False
			Exit Function
		ElseIf Request.Cookies(AcTCMSN)("SuperTF") = "1" Then 
			ACTCMS_QXYZ = True
			Exit Function
		Else 
			If ModeID=0 Then '模型ID=0将进行插件权限检测
				If Instr(Request.Cookies(AcTCMSN)("ACT_Other"),QXLX) >0 Then 
					ACTCMS_QXYZ=True
				Else
					ACTCMS_QXYZ=False 
				End If 
			Else'模块相关权限检测
				If Instr(Request.Cookies(AcTCMSN)("Purview"),"ACT"&ModeID&"-ACT") >0 Then 
					ACTCMS_QXYZ=False 
				ElseIf  Instr(Request.Cookies(AcTCMSN)("Purview"),"TCJ"&ModeID&"-TCJ") >0 Then 
					ACTCMS_QXYZ=True 
				Else 
					If Trim(Classid) ="" Then ACTCMS_QXYZ = False:Exit Function
					ACTCMS_QXYZ=ACTCMS_HQQX(ClassID,QXLX)	
				End If 
			End If 
		End If 
	End Function 

	Public Function ACTCMS_HQQX(HQQXID,HQACT)
		Dim HQarrTemp,HQi,HQL,HQACT_ClassID
		HQarrTemp=split(Request.Cookies(AcTCMSN)("HQQXLX"),",")'
		For HQI=LBound(HQarrTemp) To Ubound(HQarrTemp)'遍历
			if InStr(HQarrTemp(HQI),HQQXID) > 0 Then
				HQACT_ClassID=Split(HQarrTemp(HQI),"-")
				If UBound(HQACT_ClassID)>0 Then 
					If HQACT_ClassID(1)=HQACT Then
						ACTCMS_HQQX=True
						Exit Function
					Else	
						ACTCMS_HQQX=False
					End If 
				End if
			End  If 
		Next 
	End Function


	Sub InsertLog(UserName,lx, ResultTF, ACTError)
		Dim sqlLog, rsLog
		sqlLog = "Select top 1 * from Log_ACT"
		Set rsLog = Server.CreateObject("Adodb.RecordSet")
		rsLog.Open sqlLog, Conn, 1, 3
		rsLog.AddNew
		rsLog("UserName") = UserName
		rsLog("ResultTF") = ResultTF
		rsLog("Times") = Now()
		rsLog("lx") = lx
		rsLog("LoginIP") = GetIP()
		rsLog("ACTError") = ACTError
		rsLog.Update
		rsLog.Close:Set rsLog = Nothing
	End Sub


	Sub ACTCMSErr(Url)
	   If Url = "" Then
		 Response.Write ("<script>alert('错误提示:\n\n你没有此项操作的权限,请与系统管理员联系!');history.back();</script>")
	   Else
	    Response.Write ("<script>alert('错误提示:\n\n你没有此项操作的权限,请与系统管理员联系!');location.href='" & Url & "';</script>")
	   End If
	   Response.end
	End Sub
	Public Function IsValidEmail(Email)
		Dim names, name, I, c
		IsValidEmail = True
		names = Split(Email, "@")
		If UBound(names) <> 1 Then IsValidEmail = False: Exit Function
		For Each name In names
			If Len(name) <= 0 Then IsValidEmail = False:Exit Function
			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
		   Next
		   If Left(name, 1) = "." Or Right(name, 1) = "." Then IsValidEmail = False:Exit Function
		Next
		If InStr(names(1), ".") <= 0 Then IsValidEmail = False:Exit Function
		I = Len(names(1)) - InStrRev(names(1), ".")
		If I <> 2 And I <> 3 Then IsValidEmail = False:Exit Function
		If InStr(Email, "..") > 0 Then IsValidEmail = False
	End Function
	'检查一个数组中所有元素是否包含指定字符串
	Public Function FoundInArr(strArr, strToFind, strSplit)
		Dim arrTemp, i
		FoundInArr = False
		If InStr(strArr, strSplit) > 0 Then
			arrTemp = Split(strArr, strSplit)
			For i = 0 To UBound(arrTemp)
			If LCase(Trim(arrTemp(i))) = LCase(Trim(strToFind)) Then
				FoundInArr = True:Exit For
			End If
			Next
		Else
			If LCase(Trim(strArr)) = LCase(Trim(strToFind)) Then FoundInArr = True
		End If
	End Function


	 Public Function RecordsetToxml(RSObj,row,xmlroot)'该函数参考动网
	  Dim i,node,rs,j,DataArray
	  If xmlroot="" Then xmlroot="xml"
	  If row="" Then row="row"
	  Set RecordsetToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
	  RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot))
	  If Not RSObj.EOF Then
	   DataArray=RSObj.GetRows(-1)
	   For i=0 To UBound(DataArray,2)
		Set Node=RecordsetToxml.createNode(1,row,"")
		j=0
		For Each rs in RSObj.Fields		   
		   node.attributes.setNamedItem(RecordsetToxml.createNode(2,"ACT"&j,"")).text= DataArray(j,i)& ""
		   j=j+1
		Next
		RecordsetToxml.documentElement.appendChild(Node)
	   Next
	  End If
	  DataArray=Null
	 End Function

	 Function ACT_C(ModeID,RowID)'19
	  on error resume next
	  If not IsObject(Application(ACTCMSN &"_ModeConfig")) Then
		 Application.Lock
		 Dim RS:Set Rs=ACTEXE("select ModeID,ModeName,ModeTable,IFmake,ModeTemplate,ProjectUnit,MakeFolderDir,RecyleIF,UpFilesDir,RefreshFlag,FilePathName,ContentExtension,AutoPage,CommentCode,Commentsize,WriteComment,CommentTemp,Modekeywords,Modedescription ,ModeMakeDir From Mode_Act Order by ModeID")
		 Set Application(ACTCMSN &"_ModeConfig")=RecordsetToxml(rs,"Mode","ModeConfig")
		 Set Rs=Nothing
		 Application.unLock
	  End If
		 ACT_C=Application(ACTCMSN &"_ModeConfig").documentElement.selectSingleNode("Mode[@ACT0=" & ModeID & "]/@ACT" & RowID & "").text
	     if err then ACT_C=0:err.Clear
	 End Function



	 Function ACT_L(ClassID,RowID)
	  on error resume next
	  If not IsObject(Application(ACTCMSN &"_ClassConfig")) Then
		 Application.Lock
		 Dim RS:Set Rs=ACTEXE("select ClassID,enname,ClassName,ClassEName,FolderTemplate,ConTentTemplate,GroupIDClass,Extension,ClassKeywords,ClassDescription,ModeID From Class_Act Order by OrderID")
		 Set Application(ACTCMSN &"_ClassConfig")=RecordsetToxml(rs,"Class","ClassConfig")
		 Set Rs=Nothing
		 Application.unLock
	 End If
	     ACT_L=Application(ACTCMSN &"_ClassConfig").documentElement.selectSingleNode("Class[@ACT0=" & ClassID & "]/@ACT" & RowID & "").text
		 if err then ACT_C=0:err.Clear
	 End Function

   Function GetSubClasseName(ClassID)'栏目地址-动态和静态
	   Dim ClassRSArr
	   Name = CStr(AcTCMSN&"Navigation" & ClassID)
	   If ObjIsEmpty() Then 
			Dim ClassRS,ClassPurview
			Set ClassRS = ACTEXE("Select Classename,Extension,GroupIDClass,ModeID,ClassID,ChangesLinkUrl From Class_ACT Where classID='" & ClassID & "'")
			If ClassRS.eof Then 
				GetSubClasseName="#":Exit Function 
			Else 
				Value = ClassRS.GetRows(1):ClassRS.Close:Set ClassRS = Nothing
			End If 
       End IF
		ClassRSArr = Value
		IF ClassRSArr(5,0)<>"" Then 
				GetSubClasseName= "<a  href=""" &  ClassRSArr(5,0) & """>"& ClassRSArr(5,0) & "</a>"
		Else
			IF ClassRSArr(2,0)<>"" Or ACT_C(ClassRSArr(3,0),3)=0 Then
				GetSubClasseName =  ActCMSDM & "Article/TypeClass.asp?ClassID="& ClassRSArr(4,0) 
			Else
				GetSubClasseName = ActCMSDM&ACT_C(Application(AcTCMSN & "ModeID"),6)&ClassRSArr(0,0)'静态
			End If
		End If 
   End Function


   Function Act_MX_Arr(ModeID)'返回模型数组
	 Dim Rs
	  Set Rs=ACTEXE("Select FieldName,Title,IsNotNull,FieldType from Table_ACT  Where ModeID=" & ModeID & " order by OrderID desc,ID Desc")
	 If Not Rs.Eof Then
	  Act_MX_Arr=Rs.GetRows(-1)
	 Else
	  Act_MX_Arr=""
	 End If
	 Rs.Close:Set Rs=Nothing
   End Function



   Function Act_MX_Sys_Arr()'返回系统模型数组
	 Dim Rs
	  Set Rs =ACTEXE("SELECT ModeID, ModeName,ModeTable, ModeStatus, IFmake,ModeNote  FROM Mode_Act where ModeStatus=0 order by ModeID asc")
	 If Not Rs.Eof Then
	  Act_MX_Sys_Arr=Rs.GetRows(-1)
	 Else
	  Act_MX_Sys_Arr=""
	 End If
	 Rs.Close:Set Rs=Nothing
   End Function



	Public Function ReplaceSitelink(TempletContent)
		Dim OpenType
		Name=AcTCMSN&"ReplaceSitelink"
		If ObjIsEmpty() Then 
			Dim Rs
			Set Rs = Actexe("Select Title,Url,OpenType from Sitelink_ACT where ifs=1")
			If Rs.Eof Then Rs.Close : Set Rs = Nothing:ReplaceSitelink=TempletContent:Exit Function
			Value = Rs.GetRows(-1)
		End If 
		Dim Sitelink,i
		Sitelink=Value
		For i = 0 To Ubound(Sitelink,2)
			  If Sitelink(2,i) = ""  Then
				OpenType = ""
			  Else
				OpenType = " target=""" & Sitelink(2,i) & """"
			  End If
		 	  TempletContent = Replace(TempletContent,Sitelink(0,i), "<a href=""" & Sitelink(1,i) & """" & OpenType & ">" & Sitelink(0,i) & "</a>")
		Next
		ReplaceSitelink=TempletContent
	End Function 

	Public Function CopyFrom(C_Name)
			Dim Rs
			Set Rs = ActExe("Select Field1,Field2 from AC_ACT where Types=0 And  Field1='" & Trim(C_Name) & "'")
			If Rs.Eof Then Rs.Close : Set Rs = Nothing:CopyFrom=C_Name:Exit Function
			CopyFrom = "<a href=""" & Trim(RS("Field2")) & """ target=""_blank"">" & C_Name & "</a>"
			Rs.Close : Set Rs = Nothing
	End Function 

	Public Function Author(C_Name)
		Dim Rs
		Set Rs = ActExe("Select Field1,Field2 from AC_ACT where Types=1 And  Field1='" & Trim(C_Name) & "'")
		If Rs.Eof Then Rs.Close : Set Rs = Nothing:Author=C_Name:Exit Function
		Author = "<a href=""" & Trim(RS("Field2")) & """ target=""_blank"">" & C_Name & "</a>"
		Rs.Close : Set Rs = Nothing
	End Function