开发学院WEB开发ASP ASP动网早期一些比较常用的函数 阅读

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

 2009-05-06 10:40:10 来源:WEB开发网   
核心提示:<%' 判断提交是否來自外部Public Function ChkPost() Dim server_v1,server_v2 Chkpost=False server_v1=Cstr(Request.ServerVariables("HTTP_REFERER")) serv

<%
' 判断提交是否來自外部
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

%>

Tags:ASP 早期 一些

编辑录入:爽爽 [复制链接] [打 印]
[]
  • 好
  • 好的评价 如果觉得好,就请您
      0%(0)
  • 差
  • 差的评价 如果觉得差,就请您
      0%(0)
赞助商链接