ASP动网早期一些比较常用的函数

<%
' 判断提交是否來自外部
Public Function ChkPost()
　  Dim server_v1,server_v2
　  Chkpost=False
　  server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
　  server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
　  If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True
End Function
'系统分配随机密码
Public Function Createpass()
　  Dim Ran,i,LengthNum
　  LengthNum=16
　  Createpass=""
　  For i=1 To LengthNum
　　　  Randomize
　　　  Ran = CInt(Rnd * 2)
　　　  Randomize
　　　  If Ran = 0 Then
　　　　　  Ran = CInt(Rnd * 25) + 97
　　　　　  Createpass =Createpass& UCase(Chr(Ran))
　　　  ElseIf Ran = 1 Then
　　　　　  Ran = CInt(Rnd * 9)
　　　　　  Createpass = Createpass & Ran
　　　  ElseIf Ran = 2 Then
　　　　　  Ran = CInt(Rnd * 25) + 97
　　　　　  Createpass =Createpass& Chr(Ran)
　　　  End If
　  Next
End Function
'重写execute
Rem Function
Public Function Execute(Command)
　  If Not IsObject(Conn) Then ConnectionDatabase
　  '检查权限，防止注入攻击
　  If InStr(LCase(Command),"dv_admin")>0 And Left(ScriptName,6)<> "admin_" Then
　　　  Response.Write SaveSQLLOG(Command,"")
　　　  Command=Replace(LCase(Command),"dv_admin","dv<i>"&Chr(95)&"</i>admin")
　  End If　　　　　　　 
　  If IsDeBug = 0 Then
　　　  On Error Resume Next
　　　  Set Execute = Conn.Execute(Command)
　　　  If Err Then
　　　　　  err.Clear
　　　　　  Set Conn = Nothing
　　　　　  Response.Write SaveSQLLOG(Command,"查询数据的时候发现错误，请检查您的查询代码是否正确。<br>基于安全的理由，只显示本信息，要查看详细的错误信息，请修改您的程序文件conn.asp。把""Const IsDeBug = 0""改为：""Const IsDeBug = 1""")
　　　　　  Response.End
　　　  End If
　  Else
　　　  'Response.Write command & "<br>"
　　　  Set Execute = Conn.Execute(Command)
　  End If　 
　  SqlQueryNum = SqlQueryNum+1
End Function

'记录查询错误事件
Public Function SaveSQLLOG(sCommand,message)
　  Dim lConnStr,lConn,ldb,SQL,RS
　  ldb = "data/DvSQLLOG.mdb"
　  lConnStr = "PRovider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
　  Set lConn = Server.CreateObject("ADODB.Connection")
　  lConn.Open lConnStr
　  Set Rs = Server.CreateObject("adodb.recordset")
　  Sql="select * from dv_sql_log"
　  Rs.open sql,lconn,1,3
　  Rs.addnew
　  Rs("ScriptName")=ScriptName
　  Rs("S_Info")=Left(sCommand,255)
　  Rs("ip")=UserTrueIP
　  Rs.update
　  Rs.close
　  lConn.Execute(SQL)
　  lConn.Close
　  Set lConn = Nothing
　  SaveSQLLOG = message
End Function

'IP来源
Public Function address(sip)
　  Dim aConnStr,aConn,adb
　  Dim str1,str2,str3,str4
　  Dim  num
　  Dim country,city
　  Dim irs,SQL
　  If IsNumeric(Left(sip,2)) Then
　　　  If sip="127.0.0.1" Then sip="192.168.0.1"
　　　  str1=Left(sip,InStr(sip,".")-1)
　　　  sip=mid(sip,instr(sip,".")+1)
　　　  str2=Left(sip,instr(sip,".")-1)
　　　  sip=Mid(sip,InStr(sip,".")+1)
　　　  str3=Left(sip,instr(sip,".")-1)
　　　  str4=Mid(sip,instr(sip,".")+1)
　　　  If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then
　　　  Else　　　 
　　　　　  num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1
　　　　　  adb = "data/ipaddress.mdb"
　　　　　  aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)
　　　　　  Set AConn = Server.CreateObject("ADODB.Connection")
　　　　　  aConn.Open aConnStr

　　　  sql="select top 1 country,city from dv_address where ip1 <="&num&" and ip2 >="&num&""
　　　　　  Set irs=aConn.execute(sql)
　　　　　  If irs.EOF And irs.bof Then
　　　　　　　  country="亚洲"
　　　　　　　  city=""
　　　　　  Else
　　　　　　　  country=irs(0)
　　　　　　　  city=irs(1)
　　　　　  End If
　　　　　  Set irs=Nothing
　　　　　  Set aConn = Nothing
　　　　　  SqlQueryNum = SqlQueryNum+1
　　　  End If
　　　  address=country&city
　  Else
　　　  address="未知"
　  End If
End Function
　 
'用于用户发布的各种信息过滤，带脏话过滤
Public Function HTMLEncode(fString)
　  If Not IsNull(fString) Then
　　　  fString = replace(fString, ">", ">")
　　　  fString = replace(fString, "<", "<")
　　　  fString = Replace(fString, CHR(32), " ")　　　  '
　　　  fString = Replace(fString, CHR(9), " ")　　　　　  '
　　　  fString = Replace(fString, CHR(34), """)
　　　  fString = Replace(fString, CHR(39), "'")　  '过滤单引号
　　　  fString = Replace(fString, CHR(13), "")
　　　  fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
　　　  fString = Replace(fString, CHR(10), "<BR> ")
　　　  fString=ChkBadWords(fString)
　　　  HTMLEncode = fString
　  End If
End Function
'用于论坛本身的过滤，不带脏话过滤
Public Function iHTMLEncode(fString)
　  If Not IsNull(fString) Then
　　　  fString = replace(fString, ">", ">")
　　　  fString = replace(fString, "<", "<")
　　　  fString = Replace(fString, CHR(32), " ")
　　　  fString = Replace(fString, CHR(9), " ")
　　　  fString = Replace(fString, CHR(34), """)
　　　  fString = Replace(fString, CHR(39), "'")
　　　  fString = Replace(fString, CHR(13), "")
　　　  fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
　　　  fString = Replace(fString, CHR(10), "<BR> ")
　　　  iHTMLEncode = fString
　  End If
End Function
Public Function strLength(str)
　  If isNull(str) or Str = "" Then
　　　  StrLength = 0
　　　  Exit Function
　  End If
　  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
　　　  Next
　　　  strLength=t
　  Else
　　　  strLength=len(str)
　  End If
End Function
Public Function ChkBadWords(Str)
　  If IsNull(Str) Then Exit Function
　  Dim i
　  For i = 0 To Ubound(BadWords)
　　　  If i > UBound(rBadWord) Then
　　　　　  Str = Replace(Str,BadWords(i),"*")
　　　  Else
　　　　　  Str = Replace(Str,BadWords(i),rBadWord(i))
　　　  End If
　  Next
　  ChkBadWords = Str
End Function
Public Function Checkstr(Str)
　  If Isnull(Str) Then
　　　  CheckStr = ""
　　　  Exit Function
　  End If
　  CheckStr = Replace(Str,"'","''")
End Function
'取得带端口的URL，推荐使用
Property Get Get_ScriptNameUrl()
　  If request.servervariables("SERVER_PORT")="80" Then
　　　  Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
　  Else
　　　  Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
　  End If
End Property

'检查Email地址有效性
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

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

function cutStr(str,strlen)
　  dim l,t,c
　  l=len(str)
　  t=0
　  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
　  cutStr=left(str,i)&"..."
　  exit for
　  else
　  cutStr=str
　  end if
　  next
　  cutStr=replace(cutStr,chr(10),"")
end function

Function fixjs(Str)
　  If Str <>"" Then
　　　  str = replace(str,"\", "\\")
　　　  Str = replace(str, chr(34), "\""")
　　　  Str = replace(str, chr(39),"\'")
　　　  Str = Replace(str, chr(13), "\n")
　　　  Str = Replace(str, chr(10), "\r")
　　　  str = replace(str,"'", "'")
　  End If
　  fixjs=Str
End Function
Function enfixjs(Str)
　  If Str <>"" Then
　　　  Str = replace(str,"'", "'")
　　　  Str = replace(str,"\""" , chr(34))
　　　  Str = replace(str, "\'",chr(39))
　　　  Str = Replace(str, "\r", chr(10))
　　　  Str = Replace(str, "\n", chr(13))
　　　  Str = replace(str,"\\", "\")
　  End If
　  enfixjs=Str
End Function

Class Cls_Browser
　  Public Browser,version ,platform
　  Private Sub Class_Initialize()
　　　  Browser="unknown"
　　　  version="unknown"
　　　  platform="unknown"
　　　  Dim Agent
　　　  Agent=Request.ServerVariables("HTTP_USER_AGENT")
　　　  Agent=Split(Agent,";")
　　　  If InStr(Agent(1),"MSIE")>0 Then
　　　　　  Browser="Microsoft Internet Explorer "
　　　　　  version=Trim(Left(Replace(Agent(1),"MSIE",""),6))
　　　  ElseIf InStr(Agent(4),"Netscape")>0 Then
　　　　　  Browser="Netscape "
　　　　　  Dim tmpstr
　　　　　  tmpstr=Split(Agent(4),"/")
　　　　　  version=tmpstr(UBound(tmpstr))
　　　  End If
　　　  If InStr(Agent(2),"NT 5.2")>0 Then
　　　　　  platform="Windows 2003"
　　　  ElseIf InStr(Agent(2),"NT 5.1")>0 Then
　　　　　  platform="Windows xp"
　　　  ElseIf InStr(Agent(2),"NT 5.0")>0 Then
　　　　　  platform="Windows 2000"
　　　  ElseIf InStr(Agent(2),"9x")>0 Then
　　　　　  platform="Windows ME"
　　　  ElseIf InStr(Agent(2),"98")>0 Then
　　　　　  platform="Windows 98"
　　　  ElseIf InStr(Agent(2),"95")>0 Then
　　　　　  platform="Windows 95"
　　　  End If　 
　　　  '记录未知Agent
　　　  If Browser="unknown" or version="unknown" or platform="unknown" Then
　　　　　  Agent=Dvbbs.checkStr(Request.ServerVariables("HTTP_USER_AGENT"))
　　　　　  Dim lConnStr,lConn,ldb
　　　　　  ldb = "data/DvSQLLOG.mdb"
　　　　　  lConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
　　　　　  Set lConn = Server.CreateObject("ADODB.Connection")
　　　　　  lConn.Open lConnStr
　　　　　  lConn.Execute("insert into [Agent](UserAgent)Values('" & Agent & "')")
　　　　　  lConn.Close
　　　　　  Set lConn = Nothing
　　　  End If
　  End Sub
End Class

%>