class_sys.asp

电子备课系统

		htm2js_div = htm2js_div & "document.getElementById('" & divid & "')" & ".innerHTML='" & Str & "';}"
		If divid = "subject" Then htm2js_div = htm2js_div & vbCrLf & "if (chkdiv('subject_l')) {document.getElementById('subject_l').innerHTML='" & Str & "';}"
	End Function

	'将htm代码插入div,支持脚本插入
	'效率低下，除非必须，否则不建议使用
	Public Function htm2js_Script(Str, divid)
		divid = Trim(divid)
		If Str = "" Or IsNull(Str) Then Str = " "
		Str = Replace(Str, "\", "\\")
		Str = Replace(Str, "'", "\'")
'		Str = Replace(Str, vbCrLf, "\n")
		Str = Replace(Str, Chr(13), "")
		Str = Replace(Str, Chr(10), "\n")
		htm2js_Script = "if (chkdiv('" & divid & "')) {"
		htm2js_Script = htm2js_Script & "set_innerHTML('" & divid & "','" & Str & "');}"
	End Function

	Public Function readfile(mPath, fName)
		On Error Resume Next
		Dim fs2, f2, fpath
		fpath = Server.MapPath(mPath) & "\"
		fpath = fpath & fName
		If CacheConfig(24) = "1" Then
			Dim oStream
			Set oStream = Server.CreateObject(CacheCompont(2))
			With oStream
				.Type = 2
				.Mode = 3
				.open
				'.Charset = "utf-8"
				.Charset = "gb2312"
				.Position = oStream.size
				.open
				.loadfromfile fpath
			End With
			readfile = oStream.readtext
			oStream.Close
			Set oStream = Nothing
		Else
 			Set fs2 = Server.CreateObject(CacheCompont(1))
			Set f2 = fs2.OpenTextFile(fpath, 1, True)
			readfile = f2.ReadAll
			Set fs2 = Nothing
			Set f2 = Nothing
		End If
	End Function

	Public Function showsize(ByVal size)
		On Error Resume Next
		If size = "" Or IsNull(size) Then
			showsize = "0Byte"
			Exit Function
		End If
		showsize = size & "Byte"
		If size < 0 Then
			showsize = "0KB"
			Exit Function
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "KB"
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "MB"
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "GB"
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "TB"
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "PB"
		End If
		If size > 1024 Then
		   size = (size / 1024)
		   showsize = FormatNumber(size, 2) & "EB"
		End If
	End Function

	Public Function ChkPost()
		Dim server_v1, server_v2
		ChkPost = False
		If true_domain = 1 Then
			ChkPost = True
			Exit Function
		End If
		server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
		server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
		If server_v1 = GetUrl Then
'			Exit Function
		End If
		If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then ChkPost = True
	End Function

	Public Function filt_badstr(sSql)
		 If IsNull(sSql) Then Exit Function
		 sSql = Trim(sSql)
		 If sSql = "" Then Exit Function
		 sSql = Replace(sSql, Chr(0), "")
		 sSql = Replace(sSql, "'", "''")
		 'sSql=Replace(sSql,"%","％")
		 'sSql=Replace(sSql,"-","－")
		 filt_badstr = sSql
	End Function

	Public Function filt_astr(Str, n)
		If IsNull(Str) Then
			filt_astr = ""
			Exit Function
		End If
		filt_astr = filt_badword(Str)
		filt_astr = InterceptStr(filt_astr, n)
	End Function

	Public Function filt_html(Str)
		On Error Resume Next
		If Str = "" Then
			filt_html = ""
		Else
			If IsNull(Str) Then
				filt_html = Str
				Exit Function
			End if
			Str = Replace(Str, ">", "&gt;")
			Str = Replace(Str, "<", "&lt;")
			Str = Replace(Str, Chr(32), "&nbsp;")
			Str = Replace(Str, Chr(9), "&nbsp;")
			Str = Replace(Str, Chr(34), "&quot;")
			Str = Replace(Str, Chr(39), "&#39;")
			Str = Replace(Str, Chr(13), "")
			Str = Replace(Str, Chr(10) & Chr(10), "&nbsp; ")
			Str = Replace(Str, Chr(10), "&nbsp; ")
			filt_html = Str
		End If
	End Function

	Public Function filt_html_b(fString)
		On Error Resume Next
		If Not IsNull(fString) And fString<>"" Then
			fString = Replace(fString, ">", "&gt;")
			fString = Replace(fString, "<", "&lt;")
			fString = Replace(fString, Chr(32), " ")
			fString = Replace(fString, Chr(9), " ")
			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> ")
			filt_html_b = fString
		Else
			filt_html_b=""
		End If
	End Function

	Public 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

	Public Function InterceptStr(txt, length)
		On Error Resume Next
		Dim WINNT_CHINESE
		WINNT_CHINESE = (Len("中国") = 2)
		If WINNT_CHINESE Then InterceptStr = Left (txt,length):Exit Function
		Dim x, y, ii
		txt = Trim(txt)
		x = Len(txt)
		y = 0
		If x >= 1 Then
			For ii = 1 To x
				If Asc(Mid(txt, ii, 1)) < 0 Or Asc(Mid(txt, ii, 1)) > 255 Then '如果是汉字
					y = y + 2
				Else
					y = y + 1
				End If
				If y >= length Then
					txt = Left(Trim(txt), ii) '字符串限长
					Exit For
				End If
			Next
			InterceptStr = txt
		Else
			InterceptStr = ""
		End If
	End Function

	Public Function GetUrl()
		On Error Resume Next
		Dim sTmp
		If LCase(Request.ServerVariables("HTTPS")) = "off" Then
			sTmp = "http://"
		Else
			sTmp = "https://"
		End If
		sTmp = sTmp & Request.ServerVariables("SERVER_NAME")
		If Request.ServerVariables("SERVER_PORT") <> 80 Then sTmp = sTmp & ":" & Request.ServerVariables("SERVER_PORT")
		sTmp = sTmp & Request.ServerVariables("PATH_INFO")
		If Trim(Request.QueryString) <> "" Then sTmp = sTmp & "?" & Trim(Request.QueryString)
		GetUrl = sTmp
	End Function

	Public Function trueurl(strContent)
		On Error Resume Next
		Dim tempReg, url
		url = Trim("http://" & Request.ServerVariables("HTTP_HOST"))
		url = LCase(url & Request.ServerVariables("PATH_INFO"))
		url = Left(url, InStrRev(url, "/"))
		Set tempReg = New RegExp
		tempReg.IgnoreCase = True
		tempReg.Global = True
		tempReg.Pattern = "(^.*\/).*$" '含文件名的标准路径
		url = tempReg.replace(url, "$1")
		tempReg.Pattern = "((?:src|href).*?=[\'\u0022](?!ftp|http|https|mailto))"
		trueurl = tempReg.replace(strContent, "$1" + url)
		Set tempReg = Nothing
	End Function

	Public 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
	'只允许数字(48~57)+大(65~90)小(97~122)写字母和下划线
	Public Function chkDomain(domain)
		Dim name, i, c
		name = domain
		chkdomain = True
		If Len(name) <= 0 Then
			chkdomain = 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
				chkdomain = False
				Exit Function
			End If
		Next
	End Function

	Public Function CodeCookie(Str)
		If Is_password_cookies = 1 Then
			Dim i
			Dim StrRtn
			For i = Len(Str) To 1 Step -1
				StrRtn = StrRtn & AscW(Mid(Str, i, 1))
				If (i <> 1) Then StrRtn = StrRtn & "a"
			Next
			CodeCookie = StrRtn
		Else
			CodeCookie = Str
		End If
	End Function

	Public Function DecodeCookie(Str)
		If Is_password_cookies = 1 Then
			Dim i
			Dim StrArr, StrRtn
			StrArr = Split(Str, "a")
			For i = 0 To UBound(StrArr)
				If IsNumeric(StrArr(i)) = True Then
					StrRtn = ChrW(StrArr(i)) & StrRtn
				Else
					StrRtn = Str
					Exit Function
				End If
			Next
			DecodeCookie = StrRtn
		Else
			DecodeCookie = Str
		End If
	End Function
	Public Function BuildFile(ByVal sFile, ByVal sContent)
		On Error Resume Next
		Dim oFSO, oStream
	'	Response.Write sFile
	'	Response.Write sContent
	'	Response.end
		If CacheConfig(24) = "1" Then
			'如果选用ADODB.Steam 则强制转换成Unicode
			If Right(LCase(sFile),4) <> ".xml" Then
				sContent = AnsiToUnicode(sContent)
			End if
			Set oStream = Server.CreateObject(CacheCompont(2))
			With oStream
				.Type = 2
				.Mode = 3
				.open
				'.Charset = "utf-8"
				.Charset = "gb2312"
				.Position = oStream.size
				.WriteText = sContent
				.SaveToFile sFile, 2
				.Close
			End With
			Set oStream = Nothing
		Else
			Set oFSO = Server.CreateObject(CacheCompont(1))
			Set oStream = oFSO.CreateTextFile(sFile,True)
			oStream.Write sContent
			oStream.Close
			'增加对特殊字符的保护，强制将内容转换成Unicode
			If Err.Number<>0 Then
				sContent = AnsiToUnicode(sContent)
				Set oStream = Server.CreateObject(CacheCompont(2))
				With oStream
					.Type = 2
					.Mode = 3
					.open
					'.Charset = "utf-8"
					.Charset = "gb2312"
					.Position = oStream.size
					.WriteText = sContent
					.SaveToFile sFile, 2
					.Close
				End With
				Err.Clear
			End If
			Set oStream = Nothing
			Set oFSO = Nothing
		End If
	End Function
	'-----------Oblog4----------