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<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, ">", "&gt;")
        fString = replace(fString, "<", "&lt;")
        fString = Replace(fString, CHR(32), " ")        '&nbsp;
        fString = Replace(fString, CHR(9), " ")            '&nbsp;
        fString = Replace(fString, CHR(34), "&quot;")
        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, ">", "&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), "'")
        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

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

%>