DVBBS中使用到的一些共用Function

<%
' 判斷髮言是否來自外部
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"&Chr(95)&"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,"查詢數據的時候發現錯誤，請檢查您的查詢代碼是否正確。 基於安全的理由，只顯示本信息，要查看詳細的錯誤信息，請修改您的程序文件conn.asp。把""Const IsDeBug = 0""改為：""Const IsDeBug = 1""")
 Response.End
 End If
 Else
 'Response.Write command & " "
 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), " ")
 fString = Replace(fString, CHR(10), " ")
 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), " ")
 fString = Replace(fString, CHR(10), " ")
 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

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

%>

posted @ 2008-11-14 17:16 Athrun 阅读(387) 评论(0) 编辑收藏举报

刷新页面返回顶部

DVBBS中使用到的一些共用Function

公告