ASP動網早期一些比較常用的函數

2019-11-17 04:14:00

字體：大中小

來源：轉載

供稿：網友

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

'檢查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,"/", "http://")
 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,"http://", "/")
 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