conn.aspx.vb

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

' ***************************************************
' *        本程序由AspToAspX风火轮0.99转换生成      *
' *        http://Www.AspToAspX.Cn                  *
' *        Q Q :  139227536                         *
' *        QQ群:  17152722                          *
' *        MSN :  [e-mail]        *
' *        EMail  [e-mail]              *
' ***************************************************
Imports Microsoft.VisualBasic
Imports System.Web
Imports System.Math
Imports System.Web.SessionState


Public Class _CONN

    Public AspToAspX_Host_Class_Object As Object

Public conn
Public qs,errc,iii
Public nothis(17)
Dim _aspx_conn,_aspx_qs,_aspx_errc,_aspx_iii,_aspx_nothis,_aspx_i,_aspx_username,_aspx_cl,_aspx_rs,_aspx_AspToAspX_Str,_aspx_linkdb,_aspx_ft,_aspx_ku,_aspx_conndb,_aspx_ConnectionString,_aspx_msg,_aspx_sql,_aspx_FileName,_aspx_BoardID_1,_aspx_BoardID_2,_aspx_k,_aspx_flag,_aspx_fname,_aspx_homepage,_aspx_codestr,_aspx_codename,_aspx_sitenav,_aspx_cookexpires,_aspx_defaulthome,_aspx_sql15,_aspx_reurl,_aspx_ckname,_aspx_rm,_aspx_htmtreeurl
    Public ASPX_CONFIG As _CONFIG
    Public ASPX_ADOSTREAM As _ADOSTREAM
#Region "..."
    Public Sub AspToAspX_InitIncludeFiles()
        ASPX_CONFIG = New _CONFIG()
        ASPX_CONFIG.AspToAspX_Host_Class_Object = AspToAspX_Host_Class_Object
        ASPX_CONFIG.AspToAspX_InitIncludeFiles()
        ASPX_ADOSTREAM = New _ADOSTREAM()
        ASPX_ADOSTREAM.AspToAspX_Host_Class_Object = AspToAspX_Host_Class_Object
        ASPX_ADOSTREAM.AspToAspX_InitIncludeFiles()
    End Sub

    Public Sub AspToAspX_UnloadIncludeFiles()
        ASPX_CONFIG.AspToAspX_UnloadIncludeFiles()
        ASPX_CONFIG = Nothing
        ASPX_ADOSTREAM.AspToAspX_UnloadIncludeFiles()
        ASPX_ADOSTREAM = Nothing
    End Sub

#End Region
    Public Sub AspToAspX_Page_Init()
    On Error GoTo _AspToAspX_Err
    ASPX_CONFIG.AspToAspX_Page_Init ( )
    ASPX_ADOSTREAM.AspToAspX_Page_Init ( )
    qs = LCase ( AspToAspX_GetRequestServerVariables ( "query_string" ) ) '7
    nothis ( 0 ) = "net user" '9
    nothis ( 1 ) = "xp_cmdshell" '10
    nothis ( 2 ) = "/add" '11
    nothis ( 3 ) = "exec%20master.dbo.xp_cmdshell" '12
    nothis ( 4 ) = "net localgroup administrators" '13
    nothis ( 5 ) = "select" '14
    nothis ( 6 ) = "count" '15
    nothis ( 7 ) = "asc" '16
    nothis ( 8 ) = "char" '17
    nothis ( 9 ) = "mid" '18
    nothis ( 10 ) = "'" '19
    nothis ( 11 ) = """" '20
    nothis ( 12 ) = "insert" '21
    nothis ( 13 ) = "delete" '22
    nothis ( 14 ) = "drop" '23
    nothis ( 15 ) = "truncate" '24
    nothis ( 16 ) = "from" '25
    nothis ( 17 ) = "and user>0" '26
    errc = false '27
    For iii = 0 To Val ( UBound ( nothis ) ) '28
        If AspToAspX_CheckDBNull ( InStr ( qs , nothis ( iii ) ) ) < > 0 Then '29
            errc = true '30
        End If '31
    Next '32
    If errc Then '33
        Response.Write ( "对不起，非法URL地址请求!" ) '34
        Response.End ( ) '35
    End If '36
    On Error Resume Next '37
    conn = New ADODB.Connection ( ) '38
    If AspToAspX_CheckDBNull ( linkdb ) = 1 Then '39
        ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & ChkMapPath ( ku ) '40
        conn.Open ( ConnectionString ) '41
    Else '42
        conn.Open ( conndb ) '43
    End If '44
    If Err.Number Then '45
        Err.Clear ( ) '46
        conn = Nothing '47
        Response.Charset = "utf-8" '48
        Response.Write ( "数据库连接出错，请检查连接字串。" ) '49
        Response.End ( ) '50
    End If '51
    Response.Write ( vbCrLf )

        Exit Sub
    _AspToAspX_Err:
        AspToAspX_WriteLog ("conn_aspx Page_Init:" & Err.Description)
        Resume Next
        End Sub
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Sub makeftbbstree(ByRef  ft )
On Error Goto _AspToAspX_Err
    Dim tree
    Dim ftbbsub
    Dim dotree
    Dim treembhtm
    Dim treenl
    Dim openclose
    Dim openclosex
    Dim line
    Dim mbnl
    Dim treemb
    tree = "<table width=""120"" border=""0"" cellpadding=""0"" cellspacing=""0"" class=""text"">" & vbCrLf '250
    tree = tree + "<tr align=""left"" valign=""middle"">" & vbCrLf '251
    tree = tree + "<td width=""40"">" & vbCrLf '252
    tree = tree + "<table width=""120"" border=""0"" cellpadding=""0"" cellspacing=""0"" class=""text"">" & vbCrLf '253
    tree = tree + "<tr align=""left"" valign=""middle"">" & vbCrLf '254
    tree = tree + "<td width=""15""><a href=""#"" onClick=""expandIt('KB$bbs_id$'); return false"" style=""cursor: default;""><img id=""dir$bbs_id$"" name=""dir$bbs_id$"" src=""images/$openclose$"" width=""18"" height=""18"" border=0></a></td>" & vbCrLf '255
    tree = tree + "<td width=""15""><a href=""#"" onClick=""expandIt('KB$bbs_id$'); return false"" style=""cursor: default;""><img id=""fold$bbs_id$"" name=""fold$bbs_id$"" src=""images/$openclosex$"" width=""18"" height=""15"" border=0></a></td>" & vbCrLf '256
    tree = tree + "<td>" & vbCrLf '257
    tree = tree + "<div id=""KB$bbs_id$Parent"" class=""parent""> &nbsp;<a class=head3 href=""#"" onClick=""parent.frames('main').location.href='main.aspx?layer_1=$BBSCateID$&qs=$BBSCateQs$';expandIt('KB$bbs_id$'); return false"">$BBSCateName$</a> </div>" & vbCrLf '258
    tree = tree + "</td>" & vbCrLf '259
    tree = tree + "</tr>" & vbCrLf '260
    tree = tree + "</table>" & vbCrLf '261
    tree = tree + "</td>" & vbCrLf '262
    tree = tree + "</tr>" & vbCrLf '263
    tree = tree + "<tr align=""left"" valign=""middle"">" & vbCrLf '264
    tree = tree + "<td>" & vbCrLf '265
    tree = tree + "<div id=""KB$bbs_id$Child"" $classchild$>" & vbCrLf '266
    tree = tree + "<table width=""120"" border=""0"" cellpadding=""0"" cellspacing=""0"" class=""text"">" & vbCrLf '267
    tree = tree + "$888888$" '268
    tree = tree + "</table>" & vbCrLf '269
    tree = tree + "</div>" & vbCrLf '270
    tree = tree + "</td>" & vbCrLf '271
    tree = tree + "</tr>" & vbCrLf '272
    tree = tree + "</table>" & vbCrLf '273
    ftbbsub = "<tr align=""left"" valign=""middle"">" & vbCrLf '274
    ftbbsub = ftbbsub + "<td width=""15"" class="" ""><img src=""images/treeline.gif"" width=""18"" height=""18""></td>" & vbCrLf '275
    ftbbsub = ftbbsub + "<td width=""15"" align=""center"" valign=""top"">$line$</td>" & vbCrLf '276
    ftbbsub = ftbbsub + "<td>" & vbCrLf '277
    ftbbsub = ftbbsub + "<table width=""100%"" border=""0"" cellpadding=""0"" cellspacing=""0"" class=""text"">" & vbCrLf '278
    ftbbsub = ftbbsub + "<tr>" & vbCrLf '279
    ftbbsub = ftbbsub + "<td width=""10""><img src=""images/doc.gif"" width=""16"" height=""18""></td>" & vbCrLf '280
    ftbbsub = ftbbsub + "<td> <a class=head3 href=""main.aspx?layer_1=$BBS_Cate_PID$&layer_2=$BBS_Cate_ID$&qs=$BBS_Cate_Qs$"" target=""main""> $BBS_Cate_Name$</a></td>" & vbCrLf '281
    ftbbsub = ftbbsub + "</tr>" & vbCrLf '282
    ftbbsub = ftbbsub + "</table>" & vbCrLf '283
    ftbbsub = ftbbsub + "</td>" & vbCrLf '284
    ftbbsub = ftbbsub + "</tr>" & vbCrLf '285
    FTBBS_HTML_MB ( ft ) '286
    sql = "select BBS_ID,BBS_Cate_Name,BBS_Cate_ID,BBS_Cate_PID,BBS_Cate_Qs,treesign from " & ft & "BBS_Cate where BBS_Cate_PID='0' and deleted=0 order by totop asc" '287
    rs = New ADODB.Recordset ( ) '288
    rs.Open ( sql , conn , 1 , 1 ) '289
    dotree = "" '290
    Do While Not rs.EOF '291
        sql15 = "select BBS_Cate_Name,BBS_Cate_ID,BBS_Cate_PID,BBS_Cate_Qs from " & ft & "BBS_Cate where BBS_Cate_PID='" & AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_ID" ) .Value) & "' and deleted=0 order by totop asc" '293
        rm = New ADODB.Recordset ( ) '294
        rm.Open ( sql15 , conn , 1 , 1 ) '295
        treembhtm = "" '296
        treenl = "" '297
        If Not rm.EOF Then '298
            If AspToAspX_CheckDBNull ( AspToAspX_CheckDBNull(rs.Fields ( "treesign" ) .Value) ) = 1 Then '299
                openclose = "opentm.gif" '300
                openclosex = "openx.gif" '301
            Else '302
                openclose = "closetm.gif" '303
                openclosex = "close.gif" '304
            End If '305
            If AspToAspX_CheckDBNull ( AspToAspX_CheckDBNull(rs.Fields ( "treesign" ) .Value) ) = 0 Then '306
                k = "class=""child""" '307
            Else '308
                k = "" '309
            End If '310
            dotree = tree '311
            dotree = replace ( dotree , "$openclose$" , openclose ) '312
            dotree = replace ( dotree , "$openclosex$" , openclosex ) '313
            dotree = replace ( dotree , "$bbs_id$" , AspToAspX_CheckDBNull(rs.Fields ( 0 ) .Value) ) '314
            dotree = replace ( dotree , "$BBSCateName$" , AspToAspX_CheckDBNull(rs.Fields ( 1 ) .Value) ) '315
            dotree = replace ( dotree , "$BBSCateID$" , AspToAspX_CheckDBNull(rs.Fields ( 2 ) .Value) ) '316
            dotree = replace ( dotree , "$BBSCatePID$" , AspToAspX_CheckDBNull(rs.Fields ( 3 ) .Value) ) '317
            dotree = replace ( dotree , "$BBSCateQs$" , AspToAspX_CheckDBNull(rs.Fields ( 4 ) .Value) ) '318
            dotree = replace ( dotree , "$classchild$" , k ) '319
            i = 0 '321
            Do While Not rm.EOF '322
                If AspToAspX_CheckDBNull ( i ) = AspToAspX_CheckExpression ( rm.RecordCount ) - 1 Then '323
                    line = "<img src=""images/nodeend.gif"" width=""16"" height=""18"">" '324
                Else '325
                    line = "<img src=""images/node.gif"" width=""16"" height=""18"">" '326
                End If '327
                treembhtm = treembhtm & ftbbsub '328
                treembhtm = replace ( treembhtm , "$line$" , line ) '329
                treembhtm = replace ( treembhtm , "$BBS_Cate_Name$" , AspToAspX_CheckDBNull(rm.Fields ( 0 ) .Value) ) '330
                treembhtm = replace ( treembhtm , "$BBS_Cate_ID$" , AspToAspX_CheckDBNull(rm.Fields ( 1 ) .Value) ) '331
                treembhtm = replace ( treembhtm , "$BBS_Cate_PID$" , AspToAspX_CheckDBNull(rm.Fields ( 2 ) .Value) ) '332
                treembhtm = replace ( treembhtm , "$BBS_Cate_Qs$" , AspToAspX_CheckDBNull(rm.Fields ( 3 ) .Value) ) '333
                treenl = replace ( dotree , "$888888$" , treembhtm ) '334
                i = i + 1 '335
                rm.MoveNext ( ) '336
            Loop '337
        End If '338
        mbnl = mbnl & treenl '339
        rs.MoveNext ( ) '340
    Loop '341
    treemb = replace ( Application ( "FTBBSMB" ) ( 9 , 0 ) , "$ftbbstree$" , mbnl ) '342
    htmtreeurl = "../ftbbstree.htm" '343
    SaveToFile ( treemb , htmtreeurl ) '344
    Exit Sub
_AspToAspX_Err:
    AspToAspX_WriteLog ("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP makeftbbstree:" & Err.Description)
    Resume Next
End Sub
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Sub CloseDb()
On Error Goto _AspToAspX_Err
    If AspToAspX_CheckIsObject ( conn ) Then '463
        conn.Close ( ) '464
        conn = Nothing '465
    End If '466
    Exit Sub
_AspToAspX_Err:
    AspToAspX_WriteLog ("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP CloseDb:" & Err.Description)
    Resume Next
End Sub
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function Checkstr(ByRef  AspToAspX_Str )
On Error GoTo _AspToAspX_Err
    If IsDBNull ( AspToAspX_Str ) Then '54
        CheckStr = "" '55
        Exit Function '56
    End If '57
    AspToAspX_Str = Replace ( AspToAspX_Str , Chr ( 0 ) , "" ) '58
    AspToAspX_Str = Replace ( AspToAspX_Str , "," , "&#8218;" ) '59
    CheckStr = Replace ( AspToAspX_Str , "'" , "''" ) '60
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP Checkstr:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function CheckCharStr(ByRef  usernamepsw,ByRef flag )
On Error GoTo _AspToAspX_Err
    Dim i
    For i = 1 To Val ( AspToAspX_Len ( usernamepsw ) ) '63
        cl = mid ( usernamepsw , i , 1 ) '64
        If AspToAspX_CheckDBNull ( cl ) = "'" Or AspToAspX_CheckDBNull ( cl ) = "<" Or AspToAspX_CheckDBNull ( cl ) = ">" Or AspToAspX_CheckDBNull ( cl ) = "%" Or AspToAspX_CheckDBNull ( cl ) = "/" Or AspToAspX_CheckDBNull ( cl ) = "-" Then '65
            Response.Write ( "<script language='javascript'>" ) '66
            Response.Write ( "alert('用户名或密码中不能有非法字符!');" ) '67
            If AspToAspX_CheckDBNull ( flag ) = 1 Then '69
                Response.Write ( "window.location.href='userlogin.aspx';" ) '70
            ElseIf AspToAspX_CheckDBNull ( flag ) = 3 Then '71
                Response.Write ( "window.location.href='register.aspx';" ) '72
            Else '73
                Response.Write ( "window.location.href='userlogin.aspx?flag=Y';" ) '74
            End If '75
            Response.Write ( "</script>" ) '76
            Response.End ( ) '77
        End If '78
    Next '79
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP CheckCharStr:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function ftbbs_msg(ByRef  msg,ByRef reurl )
On Error GoTo _AspToAspX_Err
    Response.Write ( "<script language='javascript'>" ) '83
    Response.Write ( "alert('" & msg & "');" ) '84
    Response.Write ( "window.location.href='" & reurl & "';" ) '85
    Response.Write ( "</script>" ) '86
    Response.End ( ) '87
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP ftbbs_msg:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function login_msg(ByRef  msg,ByRef reurl )
On Error GoTo _AspToAspX_Err
    AspToAspX_Response_Redirect ( reurl & "?msg=" & msg ) '90
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP login_msg:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function FTBBS_HTML_MB(ByRef  ft )
On Error GoTo _AspToAspX_Err
    Response.Charset = "utf-8" '93
    If AspToAspX_VarType ( Application ( "FTBBSMB" ) ) = 0 Then '94
        sql = "select top 1 * from " & ft & "ftbbsmb where id=1" '95
        rs = New ADODB.Recordset ( ) '96
        rs.Open ( sql , conn , 1 , 1 ) '97
        Application.Lock ( ) '98
        Application.Set ( "FTBBSMB" , rs.GetRows ( - 1 ) ) '99
        Application.UnLock ( ) '100
        rs.Close ( ) '101
        rs = Nothing '102
    End If '103
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP FTBBS_HTML_MB:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function FTBBS_BZ_NAME(ByRef  BoardID_1,ByRef ft )
On Error GoTo _AspToAspX_Err