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

% >