<%
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 

	 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
		SysDomain = ActCMSDM
		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, SysDomain & 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> ")
					End If
					If ShowAllPages = True Then
						PageStr = PageStr & ("GO:<select  onChange='location.href=this.value;' style='width:55;' name='select'>")
				   For I = 1 To N
					 If Cint(CurrentPage) = I Then
						PageStr = PageStr & ("<option value=" & FileName & "?page=" & I & "&" & ParamterStr & " selected>NO." & I & "</option>")
					 Else
						 PageStr = PageStr & ("<option value=" & FileName & "?page=" & I & "&" & ParamterStr & ">NO." & I & "</option>")
					 End If
				   Next
				  PageStr = PageStr & "</select>"
				  End If
			 End If
			 ShowPagePara = PageStr
		End Function

		
		Public Function ChkNumeric(ByVal CheckID)
			If CheckID <> "" And IsNumeric(CheckID) Then
				CheckID = CLng(CheckID)
				If CheckID < 0 Then CheckID = 0
			Else
				CheckID = 0
			End If
			ChkNumeric = CheckID
		End Function
		'过滤非法的SQL字符
		Public Function RSQL(strChar)
			If strChar = "" Or IsNull(strChar) Then RSQL = "":Exit Function
			Dim strBadChar, arrBadChar, tempChar, I
			strBadChar = "$,#,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ""
			arrBadChar = Split(strBadChar, ",")
			tempChar = strChar
			For I = 0 To UBound(arrBadChar)
				tempChar = Replace(tempChar, arrBadChar(I), "")
			Next
			RSQL = tempChar
		End Function


		Public Function GetIP() 
			Dim strIPAddr 
			If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then 
				strIPAddr = Request.ServerVariables("REMOTE_ADDR") 
			ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then 
				strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1) 
			ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then 
				strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
			Else 
				strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") 
			End If 
			getIP = Replace(Trim(Mid(strIPAddr, 1, 30)), "'", "")
			getIP = Replace(getIP,";","")
			getIP = Replace(getIP,"-","")
			getIP = Replace(getIP,"(","")
			getIP = Replace(getIP,")","")
			getIP = Replace(getIP,">","")
			getIP = Replace(getIP,"<","")
			getIP = Replace(getIP,"=","")
			getIP = Replace(getIP,"*","")
		End Function

	   Function GainClassName(ClassID,opens,TitleCssName)
	   on error resume next
	   Dim ClassRSArr
	   ClassID=Trim(Replace(ClassID,"'",""))
		   Name = CStr("Navigation" & ClassID&opens&TitleCssName)
		   If ObjIsEmpty() Then 
				Dim ClassRS,ClassPurview
				Set ClassRS = ActExe("Select Classename,Extension,GroupIDClass,ModeID,ClassID,ClassName,ChangesLinkUrl From Class_ACT Where classID='" & ClassID & "'")
				 Value = ClassRS.GetRows(1):Set ClassRS = Nothing
		  End If
				ClassRSArr = Value
				IF ClassRSArr(6,0)<>"" Then 
						GainClassName= "<a " & TitleCssName & " href=""" &  ClassRSArr(6,0) & """" & opens & ">"& ClassRSArr(5,0) & "</a>"
				Else
					IF ClassRSArr(2,0)<>"" Or ACT_C(ClassRSArr(3,0),3)=0 Then
						GainClassName= "<a " & TitleCssName & " href=""" & ActCMSDM & "Article/TypeClass.asp?ClassID="& ClassRSArr(4,0) & """" & opens & ">"& ClassRSArr(5,0) & "</a>"
					Else
						GainClassName= "<a " & TitleCssName & " href=""" &  ActCMSDM&ACT_C(ClassRSArr(3,0),6)&ClassRSArr(0,0)& """" & opens & ">"& ClassRSArr(5,0) & "</a>"
					End If
				End If 
	   End Function

	   Function MoreName(ClassID)
		   Dim ClassRSArr
		   Name = CStr("More" & ClassID)
		   ClassID=Trim(Replace(ClassID,"'",""))
		   If ObjIsEmpty() Then 
				Dim ClassRS,ClassPurview
				Set ClassRS = ActExe("Select Classename,Extension,GroupIDClass,ModeID,ClassID,ClassName From Class_ACT Where classID='" & ClassID & "'")
				Value = ClassRS.GetRows(1):ClassRS.Close:Set ClassRS = Nothing
		   End IF
				ClassRSArr = Value
				IF ClassRSArr(2,0)<>"" Or ACT_C(ClassRSArr(3,0),3)=0 Then
					MoreName=   ActCMSDM & "Article/TypeClass.asp?ClassID="& ClassRSArr(4,0) 
				Else
					MoreName=   ActCMSDM&ACT_C(ClassRSArr(3,0),6)&ClassRSArr(0,0)
				End If
	   End Function


		Public Function ReturnChannelUpFilesDir(ModeID)
		   Dim InstallDir 
		   If ModeID = "" Or Not IsNumeric(ModeID) Then ModeID = 0
		   Dim CRS:Set CRS=server.CreateObject("adodb.recordset") 
		   CRS.Open "Select UpFilesDir From Mode_Act Where ModeID=" & ModeID, Conn, 1, 1
		   If CInt(ModeID) = 0 Or (CRS.EOF And CRS.BOF) Then
			ReturnChannelUpFilesDir = "UpFilesDir/"
		   Else
			ReturnChannelUpFilesDir = CRS(0)
		   End If
			ReturnChannelUpFilesDir = Left(ReturnChannelUpFilesDir, Len(ReturnChannelUpFilesDir) - 1)
			If InstallDir = "/" Then ReturnChannelUpFilesDir = "/" & ReturnChannelUpFilesDir
			CRS.Close:Set CRS = Nothing
		End Function


		Sub AddTags(ModeID,Keyword)
			Dim i,Tag,TagRs
			Set TagRs = Server.createobject("Adodb.Recordset")
			Tag = Split(Keyword,",")
			For I = 0 To UBound(Tag)
			   TagRs.Open "Select * From Tags_ACT Where TagsChar ='" & Left(Tag(I),50) & "' And ModeID =" & ModeID,Conn,1,3
			   If TagRs.Eof Then
				 TagRs.AddNew
				 TagRs("TagsChar") = Left(Tag(I),50)
				 TagRs("ModeID") = ModeID
				 TagRs("AddTime") = Now
				 TagRs.Update
				End If:TagRs.Close
			Next
		   Set TagRs = Nothing 
		End Sub 


	Function AutoSplitPage(StrNewsContent,Page_Split_page,AutoPagesNum)'自动分页
		Dim i,IsCount,OneChar,StrCount,FoundStr,Pages_i_Str,Pages_i_Arr
		AutoPagesNum = Clng(AutoPagesNum)
		Page_Split_page = Cstr(Page_Split_page)

		If Len(StrNewsContent) < Int(AutoPagesNum+Round(AutoPagesNum/5)) Then AutoSplitPage=StrNewsContent : Exit Function

		If StrNewsContent<>"" and AutoPagesNum<>0 and InStr(1,StrNewsContent,Page_Split_page)=0 then
			IsCount=True
			Pages_i_Str=""
			For i= 1 To Len(StrNewsContent)
				OneChar=Mid(StrNewsContent,i,1)
				If OneChar="<" Then
					IsCount=False
				ElseIf OneChar=">" Then
					IsCount=True
				Else
					If IsCount=True Then
						If Abs(Asc(OneChar))>255 Then
							StrCount=StrCount+2
						Else
							StrCount=StrCount+1
						End If
						If StrCount>=AutoPagesNum And i<Len(StrNewsContent) Then
							FoundStr=Left(StrNewsContent,i)
							If AllowSplitPage(FoundStr,"table|a|b>|i>|strong|div|span")=true then
								Pages_i_Str=Pages_i_Str & Trim(CStr(i)) & "," 
								StrCount=0
							End If
						End If
					End If
				End If	
			Next
			If Len(Pages_i_Str)>1 Then Pages_i_Str=Left(Pages_i_Str,Len(Pages_i_Str)-1)
			Pages_i_Arr=Split(Pages_i_Str,",")
			For i = UBound(Pages_i_Arr) To LBound(Pages_i_Arr) Step -1
				StrNewsContent=Left(StrNewsContent,Pages_i_Arr(i)) & Page_Split_page & Mid(StrNewsContent,Pages_i_Arr(i)+1)
			Next
		End If
		AutoSplitPage=StrNewsContent
	End Function
	Function AllowSplitPage(TempStr,FindStr)
		Dim Inti,BeginStr,EndStr,BeginStrNum,EndStrNum,ArrStrFind,i
		TempStr=LCase(TempStr)
		FindStr=LCase(FindStr)
		If TempStr<>"" and FindStr<>"" then
			ArrStrFind=split(FindStr,"|")
			For i = 0 to Ubound(ArrStrFind)
				BeginStr="<"&ArrStrFind(i)
				EndStr  ="</"&ArrStrFind(i)
				Inti=0
				do while instr(Inti+1,TempStr,BeginStr)<>0
					Inti=instr(Inti+1,TempStr,BeginStr)
					BeginStrNum=BeginStrNum+1
				Loop
				Inti=0
				do while instr(Inti+1,TempStr,EndStr)<>0
					Inti=instr(Inti+1,TempStr,EndStr)
					EndStrNum=EndStrNum+1
				Loop
				If EndStrNum=BeginStrNum then
					AllowSplitPage=true
				Else
					AllowSplitPage=False
					Exit Function
				End If
			Next
		Else
			AllowSplitPage=False
		End If
	End Function

	'取得每篇文章、图片链接
	Public Function GetInfoUrl(ByVal ModeID,ByVal ClassID,ByVal ID,ByVal ChangesLink,ByVal FileName,ByVal GroupID_ACT,ByVal Score_ACT)
		IF Not Isnumeric(ModeID) Then GetInfoUrl="#":Exit Function
		If ChangesLink = 1 Then
			 GetInfoUrl = FileName
		ElseIf Score_ACT>0 Or ACT_C(ModeID,3)=0  Or GroupID_ACT<>""  Or ACT_L(ClassID,6)<>"" Then '动态
			 GetInfoUrl= ActCMSDM&"Article/TypeArticle.asp?ModeID="&ModeID&"&ID=" &ID
		Else
			Dim Tmps,TmpUs 
			If Right(ACT_C(ModeID,10),1)<>"/" Then 
					 GetInfoUrl= ActCMSDM&ACT_C(ModeID,6)&FileName&ACT_C(ModeID,11)
			 Else
					GetInfoUrl= ActCMSDM&ACT_C(ModeID,6)&FileName&"/"
			End If 
		End If
	End Function 

	'显示分页的前部分
	'参数说明:PageStyle-分页样式,ItemUnit-单位,TotalPage-总页数,CurrPage-当前第N页,TotalInfo-总信息数,PerPageNumber-每页显示数
	Function  GetPageList(PageStyle,ItemUnit,TotalPage,CurrPage,TotalInfo,PerPageNumber)
	    Select Case  Cint(PageStyle)
		  Case 1
			GetPageList= "<div class=""pages""><div class=""plist"">" & "共 " & TotalInfo & " " & ItemUnit &"  页次:<font color=red> " & CurrPage & "</font>/" & TotalPage & "页  " & PerPageNumber & " " & ItemUnit &"/页 "
		 Case 2
			GetPageList= "<div class=""pages""><div class=""plist"">第<font color=red>" & CurrPage & "</font>页 共" & TotalPage & "页 "
		 Case 3
			GetPageList= "<div class=""pages""><div class=""plist"">第<font color=red>" & CurrPage & "</font>页 共" & TotalPage & "页 "
	   End Select
	End Function

	Public Function ReturnPageStyle(PageStyle)
		ReturnPageStyle = "         分页样式"
		ReturnPageStyle = ReturnPageStyle & "         <select name=""PageStyle"" style=""width:70%;"" class=""textbox"">"
		ReturnPageStyle = ReturnPageStyle & "          <option value=1"
		If PageStyle=1 Then ReturnPageStyle = ReturnPageStyle & " Selected"
		ReturnPageStyle = ReturnPageStyle & ">①首页 上一页 下一页 尾页</option>"
		ReturnPageStyle = ReturnPageStyle & "          <option value=2"
		If PageStyle=2 Then ReturnPageStyle = ReturnPageStyle & " Selected"
		ReturnPageStyle = ReturnPageStyle & ">②第N页,共N页 [1] [2] [3]</option>"
		ReturnPageStyle = ReturnPageStyle & "          <option value=3"
		If PageStyle=3 Then ReturnPageStyle = ReturnPageStyle & " Selected"
		ReturnPageStyle = ReturnPageStyle & ">③<< <  > >></option>"
		ReturnPageStyle = ReturnPageStyle & "         </select>"
	End Function

	Public  Function  GetEn(EnStr)
		Dim  EnStr4,EnStr3,EnStr2,EnStr1
		Set  EnStr1=new regexp
			EnStr1.ignorecase=true
			EnStr1.global=true
			EnStr1.pattern="[a-zA-Z0-9\- ]"
			Set  EnStr3=EnStr1.execute(EnStr)
				For  each EnStr2 in EnStr3
					EnStr4=EnStr4&EnStr2.value
				Next 
			Set  EnStr3= Nothing 
		Set  EnStr1=nothing
		EnStr4=trim(EnStr4)
		If  len(EnStr4)>0 then EnStr4=replace(EnStr4," ","-")
		While  (instr(EnStr4,"--")>0)
			EnStr4=replace(EnStr4,"--","-")
		Wend 
		GetEn =EnStr4
	End  Function 

	Public Function PinYin(StrChar)
		Dim StrLens,RsStr,StrLen,StrTitle,IFCN,i,Rs
		On  Error  Resume  Next 
		Set  RsStr=Server.Createobject("Adodb.Connection")
		RsStr.open  "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="& Server.MapPath(ActCMS_Sys(3)&"ACT_inc/pinyin.asp")
		IFCN=true
		For  i=1 to len(StrChar)
			StrTitle=IFCN
			StrLen=mid(StrChar,i,1)
			If  len(trim(StrLen)) = 1 Then 
				set rs=RsStr.execute("select top 1 pinyin from pinyin where content like '%"&StrLen&"%';")
					if not rs.eof and not rs.bof Then 
						StrLen=rs(0)
						IFCN=True 
					Else 
						IFCN=False 
					End  If 
					Rs.Close:Set  Rs = Nothing 
			Else 
				StrLen=" "
			End If 
			If  StrTitle=IFCN Then 
				StrLens=StrLens&StrLen
			Else 
				StrLens=StrLens&" "&StrLen
			End  If 
		Next 
		RsStr.Close:Set RsStr=nothing 
		PinYin=Trim(StrLens)
	End  Function
 	Public Function GetGroup_CheckBox(OptionName,SelectArr,RowNum)
	  On  Error  Resume  Next 
	   Dim n:n=0
	   Dim RSGroup,GroupName:Set RSGroup=Server.CreateObject("Adodb.Recordset")
	   IF RowNum<=0 Then RowNum=3
	   RSGroup.Open "Select GroupID,GroupSetting From Group_ACT",Conn,1,1
	   GetGroup_CheckBox="<table width=""100%"" align=""center"" border=""0"">"
	   Do While Not RSGroup.Eof
	        GetGroup_CheckBox=GetGroup_CheckBox & "<TR>"
	     For N=1 To RowNum
		    GroupName=Split(RSGroup(1),"^@$@^")(0)
		    GetGroup_CheckBox=GetGroup_CheckBox & "<TD WIDTH=""" & CInt(100 / CInt(RowNum)) & "%"">"
			If Instr(SelectArr,RSGroup(0))<>0 Then
			 GetGroup_CheckBox=GetGroup_CheckBox & "<input id="& OptionName&RSGroup(0)&" type=""checkbox"" checked name=""" & OptionName & """ value=""" & RSGroup(0) & """><label for="& OptionName&RSGroup(0) &">" & GroupName & "</label>&nbsp;&nbsp;&nbsp;&nbsp;"
			Else
			 GetGroup_CheckBox=GetGroup_CheckBox & "<input id="& OptionName&RSGroup(0)&" type=""checkbox"" name=""" & OptionName & """ value=""" & RSGroup(0) & """><label for="& OptionName&RSGroup(0) &">" & GroupName & "</label>&nbsp;&nbsp;&nbsp;&nbsp;"
			End IF
			GetGroup_CheckBox=GetGroup_CheckBox & "</TD>"
		 	RSGroup.MoveNext
			If RSGroup.Eof Then Exit For
		Next
		GetGroup_CheckBox=GetGroup_CheckBox & "</TR>"
		If RSGroup.Eof Then Exit Do
	   Loop
	   GetGroup_CheckBox=GetGroup_CheckBox & "</TABLE>"
	   RSGroup.Close:Set RSGroup=Nothing
	End Function 


	'****************************************************
	'参数说明
	  'Subject     : 邮件标题
	  'MailAddress : 发件服务器的地址,如smtp.163.com
	  'LoginName     ----登录用户名(不需要请填写"")
	  'LoginPass     ----用户密码(不需要请填写"")
	  'Email       : 收件人邮件地址
	  'Sender      : 发件人姓名
	  'Content     : 邮件内容
	  'Fromer      : 发件人的邮件地址
	'****************************************************
	  Public Function SendMail(MailAddress, LoginName, LoginPass, Subject, Email, Sender, Content, Fromer)
	   on error resume next
		Dim JMail
		  Set jmail = Server.CreateObject("JMAIL.Message") '建立发送邮件的对象
			jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值j
			jmail.Charset = "gb2312" '邮件的文字编码为国标
			jmail.ContentType = "text/html" '邮件的格式为HTML格式
			jmail.AddRecipient Email '邮件收件人的地址
			jmail.From = Fromer '发件人的E-MAIL地址
			jmail.FromName = Sender
			  If LoginName <> "" And LoginPass <> "" Then
				JMail.MailServerUserName = LoginName '您的邮件服务器登录名
				JMail.MailServerPassword = LoginPass '登录密码
			  End If

			jmail.Subject = Subject '邮件的标题 
			JMail.Body = Content
			JMail.Priority = 1'邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
			jmail.Send(MailAddress) '执行邮件发送（通过邮件服务器地址）
			jmail.Close() '关闭对象
		Set JMail = Nothing
		If Err Then
			SendMail = Err.Description
			Err.Clear
		Else
			SendMail = "OK"
		End If
	  End Function


	Public 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
	Public Function IsExpired(strClassString)
		on error resume next
		IsExpired = True
		Err = 0
		Dim xTestObj:Set xTestObj = Server.CreateObject(strClassString)
		If 0 = Err Then
			Select Case strClassString
				Case "Persits.Jpeg"
					If xTestObjResponse.Expires > Now Then
						IsExpired = False
					End If
				Case "wsImage.Resize"
					If InStr(xTestObj.errorinfo, "已经过期") = 0 Then
						IsExpired = False
					End If
				Case "SoftArtisans.ImageGen"
					xTestObj.CreateImage 500, 500, RGB(255, 255, 255)
					If Err = 0 Then
						IsExpired = False
					End If
			End Select
		End If
		Set xTestObj = Nothing
		Err = 0
	End Function
	Public Function ExpiredStr(I)
		   Dim ComponentName(3)
			ComponentName(0) = "Persits.Jpeg"
			ComponentName(1) = "wsImage.Resize"
			ComponentName(2) = "SoftArtisans.ImageGen"
			ComponentName(3) = "CreatePreviewImage.cGvbox"
			If IsObjInstalled(ComponentName(I)) Then
				If IsExpired(ComponentName(I)) Then
					ExpiredStr = "，但已过期"
				Else
					ExpiredStr = ""
				End If
			  ExpiredStr = " √支持" & ExpiredStr
			Else
			  ExpiredStr = "×不支持"
			End If
	End Function
End Class
%>