functions.asp

使用本程序在局域网内聊天

<%
Function SqlShow(Str)	'去除查询漏洞
	SqlShow=Replace(Str,"'","''")
End Function
'========================================================================
Function Print(Str)
	If IsNull(Str) Then
		Str=""
	End If
	Response.Write Str
End Function
'========================================================================
Function Printl(Str)
	If IsNull(Str) Then
		Str=""
	End If
	Response.Write Str & vbcrlf
End Function
'========================================================================
Function PageShow(Str)'字符正常的显示为字符，取消他的功能
	Dim Str1
	Str1=Str
	If IsNull(Str1) Then
		Str1=""
	End If
	'Str1=Server.HtmlEncode(Str1)
	'If Enable_UBB = true Then
	Str1=UBBCode(str1)
	'End If
	str1 = Replace(str1, "       ", "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;", 1, -1, 1)
	str1 = Replace(str1, "      ", "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;", 1, -1, 1)
	str1 = Replace(str1, "     ", "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;", 1, -1, 1)
	str1 = Replace(str1, "    ", "&nbsp;&nbsp;&nbsp;&nbsp;", 1, -1, 1)
	str1 = Replace(str1, "   ", "&nbsp;&nbsp;&nbsp;", 1, -1, 1)
	str1 = Replace(str1, vbCrLf, "<BR>" & vbCrLf, 1, -1, 1)
	PageShow = str1
End Function
'========================================================================
Function HtmlEncode(Str)'简单并且起到容错的功能，
	If IsNull(Str) Then
		Str=""
	End If
	HtmlEncode=Server.HtmlEncode(Str)
End Function
'========================================================================
Function UrlEncode(Str)
	If IsNull(Str) Then
		Str=""
	End If
	UrlEncode=Server.UrlEncode(Str)
End Function
'========================================================================
Function Cnum(Num)'把一个字符变成一个数
	If IsNumeric(Num) Then
		Cnum=Clng(Num)
	Else
		Cnum=0
	End If
End Function
'========================================================================
Function Max(Num1,Num2)
	If Num1>Num2 Then
		Max=Num1
	Else
		Max=Num2
	End If
End Function
'========================================================================
Function Min(Num1,Num2)
	If Num1>Num2 Then
		Min=Num2
	Else
		Min=Num1
	End If
End Function
'========================================================================
Function CheckErr()'页面错误捕获，记录错误日志
	If Err.Number<>0 Then
		Dim Fso,File,Path,Text
		Set Fso=CreateObject("Scripting.FileSystemObject")
		Path=Server.MapPath("ErrLog.ini")
		If Fso.FolderExists(Server.MapPath("include"))=False Then
			Path=Server.MapPath("../ErrLog.ini")
		End If
		Set File=Fso.OpenTextFile(Path,1,True)
		Text=Date & " " & Time & Chr(9) & Request.ServerVariables("REMOTE_ADDR") & Chr(9) & Request.ServerVariables("URL") & Chr(9) & Err.Number & Chr(9) & Err.Description & vbcrlf
		'Print File.Line
		If File.AtEndOfStream=False Then
			Text=Text & File.ReadAll()
		End If
		File.Close
		Set File=Nothing
		Set File=Fso.CreateTextFile(Path)
		File.Write(Text)
		File.Close
		Set File=Nothing
		Set Fso=Nothing
	End If
End Function
'========================================================================
Function Read(tPath)
	Dim Fso,Path,File
	Set Fso=CreateObject("Scripting.FileSystemObject")
	If Mid(tPath,2,1)=":" Then
		Path=tPath
	Else
		Path=Server.MapPath(tPath)
	End If
	Set File=Fso.OpenTextFile(Path,1,True)
	If File.AtEndOfStream=False Then
		Read=File.ReadAll
	Else
		Read=""
	End If
	File.Close
	Set File=Nothing
	Set Fso=Nothing
End Function
'========================================================================
Function Save(tPath,Txt)
	Dim Fso,Path,File
	Set Fso=CreateObject("Scripting.FileSystemObject")
	If Mid(tPath,2,1)=":" Then
		Path=tPath
	Else
		Path=Server.MapPath(tPath)
	End If
	Set File=Fso.CreateTextFile(Path)
	File.Write(Txt)
	File.Close
	Set File=Nothing
	Set Fso=Nothing
End Function
'========================================================================
Function IsFile(tPath)
	Dim Fso,Path
	Set Fso=CreateObject("Scripting.FileSystemObject")
	If Mid(tPath,2,1)=":" Then
		Path=tPath
	Else
		Path=Server.MapPath(tPath)
	End If
	IsFile=Fso.FileExists(Path)
	Set Fso=Nothing
End Function
'========================================================================
Function OnlyDate(ExpStr)
	Dim Num
	On Error Resume Next
	Num=Instr(1,ExpStr," ",1)
	If Num>1 Then
		OnlyDate=Left(ExpStr,Num-1)
	Else
		OnlyDate=ExpStr
	End If
End Function
'========================================================================
Function OnlyTime(ExpStr) 
Dim Num
On Error Resume Next
Num=Instr(1,ExpStr,":")
If Num>1 Then
OnlyTime=Right(ExpStr,Num-4)
Else
OnlyTime=ExpStr
End If
End Function
'========================================================================
Function CCEmpty(StrData)
	Dim Str
	Str=StrData
	Str=Replace(Str," ","")
	Str=Replace(Str,"　","")
	Str=Replace(Str,"【","")
	Str=Replace(Str,"】","")
	CCEmpty=Str
End Function
'========================================================================
Function IsSpecial(StrData)
	Dim Str,Num,i,Code
	Str=StrData
	Num=Len(Str)
	For i=1 To Num
		Code=Asc(Mid(Str,i,1))
		If (Code>=48 And Code<=57) Or (Code>=65 And Code<=90) Or (Code>=97 And Code<=122) Or (Code<0) Then
			IsSpecial=False
		Else
			IsSpecial=True
			Exit For
		End If
	Next
End Function
'========================================================================
Function RemoteIp()
	If Request.ServerVariables("HTTP_X_FORWARDED_FOR")<>"" then 
		RemoteIp=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
	Else
		RemoteIp=Request.ServerVariables("REMOTE_ADDR")
	End If
End Function
'========================================================================
Function MotherMsg(Message)
	MotherMsg="<script language=""vbscript"">" & vbcrlf
	MotherMsg=MotherMsg & "Window.Parent.Alert(""" & VbShow(Message) & """)" & vbcrlf
	MotherMsg=MotherMsg &  "</script>" & vbcrlf
End Function
'========================================================================
function IsValidEmail(email)
dim names, name, i, c
'Check for valid syntax in an email address.
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 
'========================================================================
Function TillNowTime()
	Dim NowTime
	NowTime=Timer()
	TillNowTime=Round((NowTime-PageStartTime)*1000,4)
End Function
'========================================================================
Function ShowPages(Pages,Page,Url)
Dim i,Str,FrontStr,BackStr,ShowStr,StartNum,EndNum
Str=Url
If Replace(Str,"?","")<>Str Then
	Str=Str & "&page="
Else
	Str=Str & "?page="
End If
FrontStr="<a href=""" & Str & 1 & """ title=""第一页""><img border=0 src=images/First.gif width=9 height=8></a>"
BackStr="<a href=""" & Str & Pages & """ title=""最后一页""><img border=0 src=images/Last.gif width=9 height=8></a>"
If Pages<=1 Then
	ShowPages=""
	Exit Function
End If
If Pages<=10 Then
	For i=1 To Pages
		If i<>Page Then
			ShowPages=ShowPages & "<a href=""" & Str & i & """>[" & i & "]</a> "
		Else
			ShowPages=ShowPages & "[<b>" & i & "</b>] "
		End If
	Next
	ShowPages=FrontStr & " " &  ShowPages & " " & BackStr
	Exit Function
End If
If Pages>10 Then
	StartNum=Page-2
	EndNum=StartNum+9
	If StartNum<=0 Then
		StartNum=1
		EndNum=StartNum+9
	End If
	If EndNum>Pages Then
		EndNum=Pages
		StartNum=EndNum-9
	End If
	For i=StartNum To EndNum
		If i<>Page Then
			If i=Pages Then
				ShowPages=ShowPages & "<a href=""" & Str & Pages & """ title=""最后一页"">[" & Pages & "]>></a>"
			Else				
				ShowPages=ShowPages & "<a href=""" & Str & i & """>[" & i & "]</a> "
			End If
		Else
			If i=Pages Then
				ShowPages=ShowPages & "[<b>" & Pages & "</b>] "
				ShowPages=ShowPages & BackStr
			Else
				ShowPages=ShowPages & "[<b>" & i & "</b>] "
			End If
		End If
	Next
	ShowPages=FrontStr & " " & ShowPages
	If EndNum<Pages Then
		ShowPages=ShowPages & "...<a href=""" & Str & Pages & """ title=""最后一页"">[" & Pages & "]&gt;&gt;</a>"
	End If
End If
End Function
'========================================================================
Function TurnTo(ByVal URl)
	On Error Resume Next
	Rs.Close
	CloseAll
	Response.Clear
	Response.Redirect(URL)
End Function
'========================================================================
Function isChinese(para)
dim str, c
isChinese=false
str=cstr(para)
for i = 1 to Len(para)
c=asc(mid(str,i,1))
If c<0 then
isChinese=true
EXIT Function
End If
Next
End Function
'========================================================================
Function CutStr(str,strlen)
 dim ll,tt,cc,ii
  ll=len(str)
  tt=0
  for ii=1 to ll
  cc=Abs(Asc(Mid(str,ii,1)))
  if cc>255 then
  tt=tt+2
  else
  tt=tt+1
  end if
  if tt>=strlen then
  cutStr=left(str,ii)&"..."
  exit for
  else
  cutStr=str
  end if
  next
End Function
%>