class_sys.asp

本息统基于中国网站技术人员最熟悉WindowsNT环境和Asp语言

	End Function
    Public Function filt_astr(Str, n)
        If IsNull(Str) Then
            filt_astr = ""
            Exit Function
        End If
        filt_astr = filt_badword(Str)
        filt_astr = InterceptStr(filt_astr, n)
    End Function
    Public Function filt_html(Str)
        On Error Resume Next
        If Str = "" Then
            filt_html = ""
        Else
            Str = Replace(Str, ">", ">")
            Str = Replace(Str, "<", "&lt;")
            Str = Replace(Str, Chr(32), "&nbsp;")
            Str = Replace(Str, Chr(9), "&nbsp;")
            Str = Replace(Str, Chr(34), "&quot;")
            Str = Replace(Str, Chr(39), "&#39;")
            Str = Replace(Str, Chr(13), "")
            Str = Replace(Str, Chr(10) & Chr(10), "&nbsp; ")
            Str = Replace(Str, Chr(10), "&nbsp; ")
            filt_html = Str
        End If
    End Function
    Public Function filt_html_b(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), "&#39;")
            fString = Replace(fString, Chr(13), "")
            fString = Replace(fString, Chr(10) & Chr(10), "</p><p> ")
            fString = Replace(fString, Chr(10), "<br> ")
            filt_html_b = fString
        End If
    End Function

    Public 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
    Public Function InterceptStr(txt, length)
        Dim x, y, ii
        txt = Trim(txt)
        x = Len(txt)
        y = 0
        If x >= 1 Then
            For ii = 1 To x
                If Asc(Mid(txt, ii, 1)) < 0 Or Asc(Mid(txt, ii, 1)) > 255 Then '如果是汉字
                    y = y + 2
                Else
                    y = y + 1
                End If
                If y >= length Then
                    txt = Left(Trim(txt), ii) '字符串限长
                    Exit For
                End If
            Next
            InterceptStr = txt
        Else
            InterceptStr = ""
        End If
    End Function
    '读取用户目录对应绑定的路径，未绑定返回空
    Public Function getdirdomain(udir)
        Dim tmp1, tmp2, Str
        Str = Application(cache_name & "dirdomain")
        udir = Trim(udir)
        tmp1 = InStr(Str, udir & "!!??((")
        tmp2 = Len(udir & "!!??((") + tmp1
        If tmp1 > 0 Then
            getdirdomain = Mid(Str, tmp2, InStr(tmp1, Str, "##))==") - tmp2)
        Else
            getdirdomain = ""
    End If
    End Function
    Public Function GetUrl()
        On Error Resume Next
        Dim strTemp
        If LCase(request.ServerVariables("HTTPS")) = "off" Then
        strTemp = "http://"
        Else
        strTemp = "https://"
        End If
        strTemp = strTemp & request.ServerVariables("SERVER_NAME")
        If request.ServerVariables("SERVER_PORT") <> 80 Then strTemp = strTemp & ":" & request.ServerVariables("SERVER_PORT")
        strTemp = strTemp & request.ServerVariables("URL")
        If Trim(request.QueryString) <> "" Then strTemp = strTemp & "?" & Trim(request.QueryString)
        GetUrl = strTemp
    End Function
    Public Function trueurl(strContent)
        On Error Resume Next
        Dim tempReg, url
        url = Trim("http://" & request.ServerVariables("SERVER_NAME"))
        url = LCase(url & request.ServerVariables("SCRIPT_NAME"))
        url = Left(url, InStrRev(url, "/"))
        Set tempReg = New RegExp
        tempReg.IgnoreCase = True
        tempReg.Global = True
        tempReg.Pattern = "(^.*\/).*$" '含文件名的标准路径
        url = tempReg.Replace(url, "$1")
        tempReg.Pattern = "((?:src|href).*?=[\'\u0022](?!ftp|http|https|mailto))"
        trueurl = tempReg.Replace(strContent, "$1" + url)
        Set tempReg = Nothing
    End Function
    Public 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
    Public Function chkdomain(domain)
        Dim name, i, c
        name = domain
        chkdomain = True
        If Len(name) <= 0 Then
            chkdomain = 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
               chkdomain = False
            Exit Function
           End If
       Next
    End Function
    Public Function CodeCookie(Str)
    If is_password_cookies = 1 Then
        Dim i
        Dim StrRtn
        For i = Len(Str) To 1 Step -1
            StrRtn = StrRtn & AscW(Mid(Str, i, 1))
            If (i <> 1) Then StrRtn = StrRtn & "a"
        Next
        CodeCookie = StrRtn
    Else
        CodeCookie = Str
    End If
    End Function
    
    Public Function DecodeCookie(Str)
    If is_password_cookies = 1 Then
        Dim i
        Dim StrArr, StrRtn
        StrArr = Split(Str, "a")
        For i = 0 To UBound(StrArr)
            If IsNumeric(StrArr(i)) = True Then
                StrRtn = ChrW(StrArr(i)) & StrRtn
            Else
                StrRtn = Str
                Exit Function
            End If
        Next
        DecodeCookie = StrRtn
    Else
        DecodeCookie = Str
    End If
    End Function
    Private Sub class_terminate()
    On Error Resume Next
        If IsObject(conn) Then conn.Close: Set conn = Nothing
    End Sub
    
    Public Function BuildFile(ByVal sFile, ByVal sContent)
        Dim oFSO, oStream
        If is_gb2312 = 1 Then
            Set oFSO = server.CreateObject("Scripting.FileSystemObject")
            'Response.Write "目录1：" & sFile & "<br>"
            Set oStream = oFSO.CreateTextFile(sFile, True)
            oStream.Write sContent
            oStream.Close
            Set oStream = Nothing
            Set oFSO = Nothing
        Else
            Set oStream = server.CreateObject("ADODB.Stream")
            With oStream
                .Type = 2
                .Mode = 3
                .Open
                '.Charset = "utf-8"
                .Charset = "gb2312"
                .Position = oStream.size
                .WriteText = sContent
                .SaveToFile sFile, 2
                .Close
            End With
            Set oStream = Nothing
        End If
    End Function
    '过滤掉flash UBB标记
    '[flash=500,350]http://www.kunfu.net/movie.swf[/flash]
    Function FilterUBBFlash(ByVal strFlash)
        Dim strFlash1
        strFlash1 = LCase(strFlash)
        If InStr(strFlash1, "[/flash]") > 0 Then
            strFlash1 = Replace(strFlash1, "[/flash]", "[ /flash ]")
            strFlash1 = Replace(strFlash1, "[flash", "[ flash ")
            FilterUBBFlash = strFlash1
        Else
            FilterUBBFlash = strFlash
        End If
    End Function
End Class
%>