conn.aspx.vb

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

    Response.Charset = "utf-8" '106
    AspToAspX_Str = "select BBS_Cate_ID,BBS_Cate_Name,BBS_Cate_Manager_Name,BBS_Cate_QS from " & ft & "BBS_CATE Where BBS_Cate_PID='0' and BBS_Cate_ID='" & BoardID_1 & "' order by BBS_ID asc" '107
    rs = New ADODB.Recordset ( ) '108
    rs.Open ( AspToAspX_Str , conn , 1 , 1 ) '109
    Application.Lock ( ) '110
    Application.Set ( "BBS_Cate_Name1" , AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_Name" ) .Value) ) '111
    Application.Set ( "BBS_Cate_QS1" , AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_QS" ) .Value) ) '112
    Application.UnLock ( ) '113
    rs.Close ( ) '114
    rs = Nothing '115
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP FTBBS_BZ_NAME:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function FTBBS_BZ_NAME2(ByRef  BoardID_1,ByRef BoardID_2,ByRef ft )
On Error GoTo _AspToAspX_Err
    Response.Charset = "utf-8" '118
    sql = "select BBS_Cate_ID,BBS_Cate_Name,BBS_Cate_Manager_Name,BBS_Cate_QS from " & ft & "BBS_CATE Where BBS_Cate_PID='" & BoardID_1 & "' and BBS_Cate_ID='" & BoardID_2 & "' order by BBS_ID asc" '119
    rs = New ADODB.Recordset ( ) '120
    rs.Open ( sql , conn , 1 , 1 ) '121
    Application.Lock ( ) '122
    Application.Set ( "BBS_Cate_Name2" , AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_Name" ) .Value) ) '123
    Application.Set ( "BBS_Cate_Manager_Name" , AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_Manager_Name" ) .Value) ) '124
    Application.Set ( "BBS_Cate_QS2" , AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_QS" ) .Value) ) '125
    Application.UnLock ( ) '126
    rs.Close ( ) '127
    rs = Nothing '128
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP FTBBS_BZ_NAME2:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function makefilename(ByRef  fname )
On Error GoTo _AspToAspX_Err
    fname = DateAndTime.Now '132
    fname = replace ( fname , "-" , "" ) '133
    fname = replace ( fname , " " , "" ) '134
    fname = replace ( fname , ":" , "" ) '135
    fname = replace ( fname , "PM" , "" ) '136
    fname = replace ( fname , "AM" , "" ) '137
    fname = replace ( fname , "上午" , "" ) '138
    fname = replace ( fname , "下午" , "" ) '139
    makefilename = fname '140
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP makefilename:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function GetExtendName(ByRef  FileName )
On Error GoTo _AspToAspX_Err
    Dim ExtName
    ExtName = LCase ( FileName ) '145
    ExtName = right ( ExtName , 3 ) '146
    ExtName = right ( ExtName , 3 - InStr ( ExtName , "." ) ) '147
    GetExtendName = ExtName '148
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP GetExtendName:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function IsObjInstalled(ByRef  strClassString )
On Error GoTo _AspToAspX_Err
    Dim xTestObj
    On Error Resume Next '152
    IsObjInstalled = False '153
    xTestObj = CreateObject ( strClassString ) '155
    If AspToAspX_CheckDBNull ( Err.Number ) < > - 2147221005 Then
IsObjInstalled = True
Else
IsObjInstalled = False
End If
   '156
        xTestObj = Nothing '157
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP IsObjInstalled:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Public Function ChkMapPath(ByVal strPath )
On Error GoTo _AspToAspX_Err
    Dim fullPath
    On Error Resume Next '165
    strPath = Replace ( Replace ( Trim ( strPath ) , "//" , "/" ) , "\\" , "\" ) '167
    If AspToAspX_CheckDBNull ( strPath ) = EmptyString.Value Then
strPath = "."
End If
   '168
        If AspToAspX_CheckDBNull ( InStr ( strPath , ":\" ) ) = 0 Then '169
            fullPath = Server.MapPath ( strPath ) '170
        Else '171
            strPath = Replace ( strPath , "/" , "\" ) '172
            fullPath = Trim ( strPath ) '173
            If AspToAspX_CheckDBNull ( Right ( fullPath , 1 ) ) = "\" Then '174
                fullPath = Left ( fullPath , AspToAspX_Len ( fullPath ) - 1 ) '175
            End If '176
        End If '177
        ChkMapPath = fullPath '178
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP ChkMapPath:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function userlogin(ByRef  ft )
On Error GoTo _AspToAspX_Err
    Dim UserName
    UserName = getcookie ( "name" ) '182
    If AspToAspX_CheckDBNull ( UserName ) < > EmptyString.Value Then '183
        sql = "select top 1 clubuser_name,clubuser_password,bbsmanager from " & ft & "clubuser Where clubuser_name='" & UserName & "'" '184
        rs = New ADODB.Recordset ( ) '185
        rs.Open ( sql , conn , 1 , 1 ) '186
        If rs.BOF And rs.EOF Then '187
            userlogin = "N" '188
        Else '189
            If AspToAspX_CheckDBNull ( AspToAspX_CheckDBNull(rs.Fields ( "clubuser_password" ) .Value) ) = DecodeCookie ( ( getcookie ( "clubuser_password" ) ) ) Then '190
                userlogin = "Y" '191
                Response.Cookies ( "bz" ).Value = AspToAspX_CheckDBNull(rs.Fields ( "bbsmanager" ) .Value) '192
            Else '193
                userlogin = "N" '194
            End If '195
        End If '196
        rs.Close ( ) '197
        rs = Nothing '198
    Else '199
        userlogin = "N" '200
    End If '201
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP userlogin:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function headhtml()
On Error GoTo _AspToAspX_Err
    Dim head
    FTBBS_HTML_MB ( ft ) '204
    sitenav = Application ( "FTBBSMB" ) ( 65 , 0 ) '205
    head = sitenav & vbCrLf '206
    head = head + "<table width=""99%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""0"">" & vbCrLf '207
    head = head + "<tr>" & vbCrLf '208
    head = head + "<td width=""13%"" height=""70""><div align=""left""><img src=""images/tmlogo.gif"" width=""112"" height=""50""></div></td>" & vbCrLf '209
    head = head + "<td width=""87%""><div align=""right"">" & vbCrLf '210
    head = head + "<script language=""JavaScript"" src=""sitead.js""></script>" & vbCrLf '211
    head = head + "</div></td>" & vbCrLf '212
    head = head + "</tr>" & vbCrLf '213
    head = head + "</table>" & vbCrLf '214
    headhtml = head '215
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP headhtml:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function GetOpInfo(ByRef  AspToAspX_Str,ByRef Flag )
On Error GoTo _AspToAspX_Err
    Dim FT
    If AspToAspX_CheckDBNull ( InStr ( AspToAspX_Str , ";" ) ) > 0 Then '218
        FT = AspToAspX_Split ( AspToAspX_Str , ";" ) '220
        If AspToAspX_CheckDBNull ( UBound ( FT ) ) > = 2 Then '221
            FT ( 2 ) = replace ( FT ( 2 ) , ")" , "" ) '222
            FT ( 2 ) = replace ( FT ( 2 ) , "NT 5.2" , "2003" ) '223
            FT ( 2 ) = replace ( FT ( 2 ) , "NT 5.1" , "XP" ) '224
            FT ( 2 ) = replace ( FT ( 2 ) , "NT 5.0" , "2000" ) '225
            FT ( 2 ) = replace ( FT ( 2 ) , "9x" , "Me" ) '226
            FT ( 1 ) = Trim ( FT ( 1 ) ) '227
            FT ( 2 ) = Trim ( FT ( 2 ) ) '228
            If AspToAspX_CheckDBNull ( Flag ) = 1 Then '229
                GetOpInfo = FT ( 1 ) '230
            Else '231
                GetOpInfo = FT ( 2 ) '232
            End If '233
        Else '234
            If AspToAspX_CheckDBNull ( Flag ) = 1 Then '235
                GetOpInfo = "未知" '236
            Else '237
                GetOpInfo = "未知" '238
            End If '239
        End If '240
    Else '241
        If AspToAspX_CheckDBNull ( Flag ) = 1 Then '242
            GetOpInfo = "未知" '243
        Else '244
            GetOpInfo = "未知" '245
        End If '246
    End If '247
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP GetOpInfo:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Public Function getcode()
On Error GoTo _AspToAspX_Err
    Dim tmpstr
    Dim tempstr
    Randomize ( ) '348
    tempstr = AspToAspX_CStr ( AspToAspX_Int ( 900000 * AspToAspX_Rnd ) + 100000 ) '349
    getcode = "<img src=""inc/ftbbscode.aspx?s=" & tempstr & """ style=""cursor:hand;border:1px solid #ccc;vertical-align:top;"" onclick=""this.src='inc/ftbbscode.aspx?s=" & tempstr & "';"" alt=""看不清?点一下"" id=""ftbbscodeimg"" /><input type=""hidden"" name=""codename"" value=""" & tempstr & """ />" '350
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP getcode:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Public Function codepass()
On Error GoTo _AspToAspX_Err
    Dim CodeStr
    Dim codename
    CodeStr = Trim ( Request ( "CodeStr" ) ) '355
    codename = Trim ( Request ( "codename" ) ) '356
    If AspToAspX_CStr ( Session ( "GetCode" & codename ) ) = AspToAspX_CStr ( CodeStr ) And AspToAspX_CheckDBNull ( CodeStr ) < > EmptyString.Value Then '357
        codepass = True '358
        Session ( "GetCode" & codename ) = Nothing '359
    Else '360
        codepass = False '361
        Session ( "GetCode" & codename ) = Nothing '362
    End If '363
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP codepass:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Public Function Ftbbs_Time()
On Error GoTo _AspToAspX_Err
    Dim Ftbbs_Year
    Dim Ftbbs_Month
    Dim Ftbbs_Day
    Dim Ftbbs_Hour
    Dim Ftbbs_Minute
    Dim Ftbbs_Second
    Ftbbs_Time = DateAndTime.Now '367
    Ftbbs_Year = Year ( Ftbbs_Time ) '368
    Ftbbs_Month = Month ( Ftbbs_Time ) '369
    Ftbbs_Day = Day ( Ftbbs_Time ) '370
    Ftbbs_Hour = Hour ( Ftbbs_Time ) '371
    Ftbbs_Minute = Minute ( Ftbbs_Time ) '372
    Ftbbs_Second = Second ( Ftbbs_Time ) '373
    Ftbbs_Time = Ftbbs_Year & "-" & Ftbbs_Month & "-" & Ftbbs_Day & " " & Ftbbs_Hour & ":" & Ftbbs_Minute & ":" & Ftbbs_Second '374
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP Ftbbs_Time:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function ft_home(ByRef  defaulthome )
On Error GoTo _AspToAspX_Err
    If AspToAspX_CheckDBNull ( defaulthome ) = 1 Then '377
        If AspToAspX_GetRequestCookies ( "ftbbstype" ) = 1 Then '378
            homepage = "default_list.aspx" '379
        Else '380
            homepage = "ftbbshome.aspx" '381
        End If '382
    Else '383
        If AspToAspX_GetRequestCookies ( "ftbbstype" ) = 1 Then '384
            homepage = "default_list.aspx" '385
        Else '386
            homepage = "main.aspx" '387
        End If '388
    End If '389
    ft_home = homepage '390
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP ft_home:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function chkpost()
On Error GoTo _AspToAspX_Err
    Dim url1
    Dim url2
    chkpost = true '394
    url1 = AspToAspX_CStr ( AspToAspX_GetRequestServerVariables ( "HTTP_REFERER" ) ) '395
    url2 = AspToAspX_CStr ( AspToAspX_GetRequestServerVariables ( "SERVER_NAME" ) ) '396
    If AspToAspX_CheckDBNull ( Mid ( url1 , 8 , AspToAspX_Len ( url2 ) ) ) < > url2 Then '397
        chkpost = false '398
        Exit Function '399
    End If '400
    Exit Function
_AspToAspX_Err:
    AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP chkpost:" & Err.Description)
    Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\CONN.ASP
Function CodeCookie(ByRef  AspToAspX_Str )
On Error GoTo _AspToAspX_Err
    Dim i
    Dim CookieStr
    For i = AspToAspX_Len ( AspToAspX_Str ) To 1 Step - 1 '405
        CookieStr = CookieStr & Asc ( Mid ( AspToAspX_Str , i , 1 ) ) '406
    If ( AspToAspX_CheckDBNull ( i ) < > 1 ) Then
CookieStr = CookieStr & "a"
End If
   '407
    Next '408
    CodeCookie = CookieStr '409
    Exit Function
_AspToAspX_Err: