ubbcode.aspx.vb

本程序修改自飞天BBS 7.0 将原来的ASP语法迁移为ASP.NET并封装成DLL ASP.NET相对ASP有更快的执行效率以及更高的并发访问量 基于ASP.NET的DLL可以运行在支持ASP

End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function FilterJS(ByRef  v )
On Error GoTo _AspToAspX_Err
    Dim t
    Dim re
    Dim reContent
    If Not IsDBNull ( v ) Then '133
        re = New VBScript_RegExp_55.RegExp '137
        re.IgnoreCase = true '138
        re.Global = True '139
        re.Pattern = "(javascript)" '140
        t = re.Replace ( v , "&#106avascript" ) '141
        re.Pattern = "(jscript:)" '142
        t = re.Replace ( t , "&#106script:" ) '143
        re.Pattern = "(js:)" '144
        t = re.Replace ( t , "&#106s:" ) '145
        re.Pattern = "(about:)" '148
        t = re.Replace ( t , "about&#58" ) '149
        re.Pattern = "(file:)" '150
        t = re.Replace ( t , "file&#58" ) '151
        re.Pattern = "(document.cookie)" '152
        t = re.Replace ( t , "documents&#46cookie" ) '153
        re.Pattern = "(vbscript:)" '154
        t = re.Replace ( t , "&#118bscript:" ) '155
        re.Pattern = "(vbs:)" '156
        t = re.Replace ( t , "&#118bs:" ) '157
        re.Pattern = "(on(exit|error|click|key))" '158
        t = re.Replace ( t , "&#111n$2" ) '159
        FilterJS = t '162
        re = Nothing '163
    End If '164
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP FilterJS:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function HTMLEncode(ByRef  fString )
On Error GoTo _AspToAspX_Err
    fString = replace ( fString , ">" , ">" ) '167
    fString = replace ( fString , "<" , "&lt;" ) '168
    fString = replace ( fString , " " , "&nbsp;" ) '169
    fString = Replace ( fString , CHR ( 13 ) , "" ) '170
    fString = Replace ( fString , CHR ( 10 ) & CHR ( 10 ) , "<BR><BR>" ) '171
    fString = Replace ( fString , CHR ( 10 ) , "<BR>" ) '172
    HTMLEncode = fString '173
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP HTMLEncode:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function fthtmlEncode(ByRef  fString )
On Error GoTo _AspToAspX_Err
    If Not IsDBNull ( fString ) Then '176
        fString = replace ( fString , ">" , "&gt;" ) '177
        fString = replace ( fString , "<" , "&lt;" ) '178
        fString = Replace ( fString , CHR ( 32 ) , "&nbsp;" ) '179
        fString = Replace ( fString , CHR ( 9 ) , "&nbsp;" ) '180
        fString = Replace ( fString , CHR ( 34 ) , "&quot;" ) '181
        fString = Replace ( fString , CHR ( 39 ) , "&#39;" ) '182
        fString = Replace ( fString , CHR ( 13 ) , "" ) '183
        fString = Replace ( fString , CHR ( 10 ) & CHR ( 10 ) , "</P><P> " ) '184
        fString = Replace ( fString , CHR ( 10 ) , "<BR> " ) '185
        fthtmlEncode = fString '186
    End If '187
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP fthtmlEncode:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function fthtmlCode(ByRef  fString )
On Error GoTo _AspToAspX_Err
    If Not IsDBNull ( fString ) Then '190
        fString = replace ( fString , "&gt;" , ">" ) '191
        fString = replace ( fString , "&lt;" , "<" ) '192
        fString = Replace ( fString , "&nbsp;" , " " ) '193
        fString = Replace ( fString , "&quot;" , CHR ( 34 ) ) '194
        fString = Replace ( fString , "&#39;" , CHR ( 39 ) ) '195
        fString = Replace ( fString , "&amp;" , "&" ) '196
        fString = Replace ( fString , "</P><P> " , CHR ( 10 ) & CHR ( 10 ) ) '197
        fString = Replace ( fString , "<br>" , chr ( 13 ) ) '198
        fthtmlCode = fString '199
    End If '200
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP fthtmlCode:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function nohtml(ByRef  AspToAspX_Str )
On Error GoTo _AspToAspX_Err
    Dim re
    re = New VBScript_RegExp_55.RegExp '204
    re.IgnoreCase = true '205
    re.Global = True '206
    re.Pattern = "(\<.[^\<]*\>)" '207
    AspToAspX_Str = re.replace ( AspToAspX_Str , "" ) '208
    re.Pattern = "(\<\/[^\<]*\>)" '209
    AspToAspX_Str = re.replace ( AspToAspX_Str , "" ) '210
    nohtml = AspToAspX_Str '211
    re = Nothing '212
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP nohtml:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function clearnulllen(ByRef  fString )
On Error GoTo _AspToAspX_Err
    If Not IsDBNull ( fString ) Then '215
        fString = LCase ( fString ) '216
        fString = Replace ( fString , "&nbsp;" , "" ) '217
        fString = Replace ( fString , "<br>" , "" ) '218
        fString = Replace ( fString , "<br />" , "" ) '219
        fString = Replace ( fString , "<div>" , "" ) '220
        fString = Replace ( fString , "</div>" , "" ) '221
        fString = Replace ( fString , " " , "" ) '222
        clearnulllen = AspToAspX_Len ( fString ) '223
    End If '224
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP clearnulllen:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP
Function RegExReplace(ByRef  AspToAspX_Str,ByRef patrn,ByRef str2 )
On Error GoTo _AspToAspX_Err
    Dim regEx
    regEx = New VBScript_RegExp_55.RegExp '229
    regEx.IgnoreCase = True '230
    regEx.Global = True '231
    regEx.Pattern = patrn '232
    RegExReplace = regEx.Replace ( AspToAspX_Str , str2 ) '233
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\INC\UBBCODE.ASP RegExReplace:" & Err.Description)
    Resume Next
End Function
#Region "..."
    Public Property AspToAspX_Str
        Get
            On Error Resume Next
            AspToAspX_Str = AspToAspX_Host_Class_Object.AspToAspX_Str
            If Err.Number = 438 Then
                Err.Clear
                AspToAspX_Str = _aspx_AspToAspX_Str
            End If
        End Get
        Set(ByVal value)
            On Error Resume Next
            AspToAspX_Host_Class_Object.AspToAspX_Str = value
            If Err.Number = 438 Then
                Err.Clear
                _aspx_AspToAspX_Str = value
            End If
        End Set
    End Property
#End Region
End Class