📄 dhfun.aspx.vb
字号:
' ***************************************************
' * 本程序由AspToAspX风火轮0.99转换生成 *
' * http://Www.AspToAspX.Cn *
' * Q Q : 139227536 *
' * QQ群: 17152722 *
' * MSN : gzliangjianhua@hotmail.com *
' * EMail AspToDll@vip.163.com *
' ***************************************************
Imports Microsoft.VisualBasic
Imports System.Web
Imports System.Math
Imports System.Web.SessionState
Public Class _ADMIN_DHFUN
Public AspToAspX_Host_Class_Object As Object
Dim _aspx_conn,_aspx_sql,_aspx_rs,_aspx_ft,_aspx_i,_aspx_AspToAspX_Str
#Region "..."
Public Sub AspToAspX_InitIncludeFiles()
End Sub
Public Sub AspToAspX_UnloadIncludeFiles()
End Sub
#End Region
Public Sub AspToAspX_Page_Init()
On Error GoTo _AspToAspX_Err
Response.Write ( vbCrLf )
Exit Sub
_AspToAspX_Err:
AspToAspX_WriteLog ("dhfun_aspx Page_Init:" & Err.Description)
Resume Next
End Sub
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function maketodh(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim sql
Dim rs1
Dim rs
Dim emptying
Dim m
Dim dhnl
Dim AspToAspX_Str
Dim nl
Dim dhurl
sql = "select BBS_ID,BBS_Cate_Name,BBS_Cate_ID,BBS_Cate_PID,BBS_Cate_Qs From " & ft & "BBS_Cate where deleted=0 and BBS_Cate_PID='0' order by BBS_ID " '4
Rs1 = Conn.Execute ( sql ) '5
dhnl = "" '6
Do While Not rs1.EOF '7
dhnl = dhnl + "<option value=main.aspx?layer_1=" & AspToAspX_CheckDBNull(rs1.Fields ( "BBS_Cate_ID" ) .Value) & "&qs=" & AspToAspX_CheckDBNull(rs1.Fields ( "BBS_Cate_Qs" ) .Value) & ">╋ <b>" & AspToAspX_CheckDBNull(rs1.Fields ( "BBS_Cate_Name" ) .Value) & "</b></option>" '8
AspToAspX_Str = "select BBS_ID,BBS_Cate_ID,BBS_Cate_PID,BBS_Cate_Name,BBS_Cate_Qs From " & ft & "BBS_Cate where deleted=0 and BBS_Cate_PID='" & AspToAspX_CheckDBNull(rs1.Fields ( "BBS_Cate_ID" ) .Value) & "' order by BBS_ID" '9
Rs = Conn.Execute ( AspToAspX_Str ) '10
Do While Not rs.EOF '11
dhnl = dhnl + "<option value=main.aspx?layer_1=" & AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_PID" ) .Value) & "&layer_2=" & AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_ID" ) .Value) & "&qs=" & AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_Qs" ) .Value) & "> ┠ " & AspToAspX_CheckDBNull(rs.Fields ( "BBS_Cate_Name" ) .Value) & "</option>" '12
rs.MoveNext ( ) '13
Loop '14
rs1.MoveNext ( ) '15
Loop '16
Rs1 = Nothing '17
nl = "<form name=""myurl""><select name=""select"" size=""1"" onchange=""location=this.options[this.selectedIndex].value""><option value=#>论坛导航菜单</option>" + dhnl + "</select></form>" '18
nl = "document.write('" & nl & "');" '19
dhurl = "../ftbbsdh.js" '20
SaveToFile ( nl , dhurl ) '21
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP maketodh:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function bbsad(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim nlstr
Dim adnl
Dim bbsadurl
sql = "select top 3 id,Boardid_1,Boardid_2,user_id,name,title,hit,rep,dateh,redate,bbs_img,bbs_img_display,huati,img_url_display,P_display,picture,sign,zhiye,htmfilename,bbstop,bbstop1,titlecolor,boardsign,reinfo from " & ft & "bbstitle where deleted=0 and boardsign=1 order by bbstop1 desc,bbstop desc,id desc" '24
rs = New ADODB.Recordset ( ) '25
rs.Open ( sql , conn , 3 , 1 ) '26
If Not rs.EOF Then '27
nlstr = "" '28
Do While Not rs.EOF '29
nlstr = nlstr & "·<a class=""f14"" href=" & AspToAspX_CheckDBNull(rs.Fields ( "htmfilename" ) .Value) & " title=" & AspToAspX_CheckDBNull(rs.Fields ( "title" ) .Value) & " target=""_blank""><font color=" & AspToAspX_CheckDBNull(rs.Fields ( "titlecolor" ) .Value) & ">" & AspToAspX_CheckDBNull(rs.Fields ( "title" ) .Value) & "(" & formatdatetime ( AspToAspX_CheckDBNull(rs.Fields ( "dateh" ) .Value) , 2 ) & ")</font></a>" '30
rs.MoveNext ( ) '31
Loop '32
rs.Close ( ) '33
rs = Nothing '34
adnl = "<tr align=middle>" '35
adnl = adnl & "<td height=25 colspan=6 class=""loopborder1""> <marquee truespeed direction=""left"" scrollamount=""1"" scrolldelay=""50"" width=""99%"" onMouseOver=""this.stop()"" onMouseOut=""this.start()"">" & nlstr & "</marquee></td></tr>" '36
adnl = "document.write('" & adnl & "')" '37
Else '38
adnl = "document.write('')" '39
End If '40
bbsadurl = "../bbsad.js" '42
SaveToFile ( adnl , bbsadurl ) '43
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP bbsad:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function listad(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim nlstr
Dim tr
Dim adnl
Dim bbsadurl
sql = "select * from " & ft & "ftbbs_ad where adflag=0 and adtype=1 order by bytime desc" '46
rs = New ADODB.Recordset ( ) '47
rs.Open ( sql , conn , 3 , 1 ) '48
If Not rs.EOF Then '49
nlstr = "" '50
i = 0 '51
Do While Not rs.EOF '52
tr = "" '53
i = i + 1 '54
If AspToAspX_CheckDBNull ( i Mod 4 ) = 0 Then '55
tr = "<tr class=""f12"">" '56
End If '57
nlstr = nlstr & "<td width=""25%"" height=""20"" align=""left""><a href=" & AspToAspX_CheckDBNull(rs.Fields ( "adurl" ) .Value) & " target=""_blank""><font color=" & AspToAspX_CheckDBNull(rs.Fields ( "adcolor" ) .Value) & ">" & AspToAspX_CheckDBNull(rs.Fields ( "adtitle" ) .Value) & "</font></a></td>" & tr '58
rs.MoveNext ( ) '59
Loop '60
rs.Close ( ) '61
rs = Nothing '62
adnl = "<div class=""text_ad""><table width=""96%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1""><tr class=""f12"">" & nlstr & "</tr></table></div>" '64
adnl = "document.write('" & adnl & "')" '65
Else '66
adnl = "document.write('')" '67
End If '68
bbsadurl = "../listad.js" '70
SaveToFile ( adnl , bbsadurl ) '71
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP listad:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function default_listbbsad(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim nlstr
Dim adnl
Dim bbsadurl
sql = "select top 3 id,Boardid_1,Boardid_2,user_id,name,title,hit,rep,dateh,redate,bbs_img,bbs_img_display,huati,img_url_display,P_display,picture,sign,zhiye,htmfilename,bbstop,bbstop1,titlecolor,boardsign,reinfo from " & ft & "bbstitle where deleted=0 and boardsign=1 order by id desc" '75
rs = New ADODB.Recordset ( ) '76
rs.Open ( sql , conn , 3 , 1 ) '77
If Not rs.EOF Then '78
nlstr = "" '79
Do While Not rs.EOF '80
nlstr = nlstr & "·<a class=""f14"" href=" & AspToAspX_CheckDBNull(rs.Fields ( "htmfilename" ) .Value) & " title=" & AspToAspX_CheckDBNull(rs.Fields ( "title" ) .Value) & " target=""_blank""><font color=" & AspToAspX_CheckDBNull(rs.Fields ( "titlecolor" ) .Value) & ">" & AspToAspX_CheckDBNull(rs.Fields ( "title" ) .Value) & "(" & formatdatetime ( AspToAspX_CheckDBNull(rs.Fields ( "dateh" ) .Value) , 2 ) & ")</font></a>" '81
rs.MoveNext ( ) '82
Loop '83
rs.Close ( ) '84
rs = Nothing '85
adnl = adnl & "<marquee truespeed direction=""left"" scrollamount=""1"" scrolldelay=""30"" width=""99%"" onMouseOver=""this.stop()"" onMouseOut=""this.start()"">" & nlstr & "</marquee>" '86
adnl = "document.write('" & adnl & "')" '87
Else '88
adnl = "document.write('')" '89
End If '90
bbsadurl = "../df_listad.js" '92
SaveToFile ( adnl , bbsadurl ) '93
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP default_listbbsad:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function default_listad(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim nlstr
Dim tr
Dim adnl
Dim bbsadurl
sql = "select * from " & ft & "ftbbs_ad where adflag=0 and adtype=1 order by bytime desc" '96
rs = New ADODB.Recordset ( ) '97
rs.Open ( sql , conn , 3 , 1 ) '98
If Not rs.EOF Then '99
nlstr = "" '100
i = 0 '101
Do While Not rs.EOF '102
tr = "" '103
i = i + 1 '104
If AspToAspX_CheckDBNull ( i Mod 4 ) = 0 Then '105
tr = "<tr>" '106
End If '107
nlstr = nlstr & "<td width=""25%"" height=""25"" class=""ftbbsad"" align=""center""><a href=" & AspToAspX_CheckDBNull(rs.Fields ( "adurl" ) .Value) & " target=""_blank""><font color=" & AspToAspX_CheckDBNull(rs.Fields ( "adcolor" ) .Value) & ">" & AspToAspX_CheckDBNull(rs.Fields ( "adtitle" ) .Value) & "</font></a></td>" & tr '108
rs.MoveNext ( ) '109
Loop '110
rs.Close ( ) '111
rs = Nothing '112
adnl = "<table width=""99%"" border=""0"" align=""center"" cellpadding=""0""><tr> <td height=2><spacer height=""2"" type=""block""></td></tr></table>" '113
adnl = adnl & "<table width=""99%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""maintbbg""><tr>" & nlstr & "</tr></table>" '114
adnl = adnl & "<table width=""99%"" border=""0"" align=""center"" cellpadding=""0""><tr> <td height=2><spacer height=""2"" type=""block""></td></tr></table>" '115
adnl = "document.write('" & adnl & "')" '116
Else '117
adnl = "document.write('')" '118
End If '119
bbsadurl = "../default_list_ad.js" '121
SaveToFile ( adnl , bbsadurl ) '122
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP default_listad:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function sitead(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim adtype
Dim adtitle
Dim adurl
Dim ad_h
Dim ad_w
Dim adnl
Dim bbsadurl
sql = "select top 1 * from " & ft & "ftbbs_ad where adflag=0 and ad_p=2 and (adtype=2 or adtype=3) order by id desc" '125
rs = New ADODB.Recordset ( ) '126
rs.Open ( sql , conn , 3 , 1 ) '127
If Not rs.EOF Then '128
adtype = AspToAspX_CheckDBNull(rs.Fields ( "adtype" ) .Value) '129
adtitle = AspToAspX_CheckDBNull(rs.Fields ( "adtitle" ) .Value) '130
adurl = AspToAspX_CheckDBNull(rs.Fields ( "adurl" ) .Value) '131
ad_h = AspToAspX_CheckDBNull(rs.Fields ( "ad_h" ) .Value) '132
ad_w = AspToAspX_CheckDBNull(rs.Fields ( "ad_w" ) .Value) '133
If AspToAspX_CheckDBNull ( adtype ) = 2 Then '134
adnl = "<a href=" & adurl & " target=""_blank""><img src=" & adtitle & " width=" & ad_w & " height=" & ad_h & " border=""0""></a>" '135
ElseIf AspToAspX_CheckDBNull ( adtype ) = 3 Then '136
adnl = "<object classid=""clsid:D27CDB6E-AE6D-11cf-96B8-444553540000"" codebase=""http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=6,0,29,0"" width=" & ad_w & " height=" & ad_h & ">" '137
adnl = adnl & "<param name=""movie"" value=" & adtitle & ">" '138
adnl = adnl & "<param name=""quality"" value=""high"">" '139
adnl = adnl & "<embed src=" & adtitle & " quality=""high"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" type=""application/x-shockwave-flash"" width=" & ad_w & " height=" & ad_h & "></embed></object>" '140
End If '141
adnl = "document.write('" & adnl & "')" '142
Else '143
adnl = "<object classid=""clsid:D27CDB6E-AE6D-11cf-96B8-444553540000"" codebase=""http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=6,0,29,0"" width=""600"" height=""60"">" '144
adnl = adnl & "<param name=""movie"" value=""flashad/ftbbs600x60.swf"">" '145
adnl = adnl & "<param name=""quality"" value=""high"">" '146
adnl = adnl & "<embed src=""flashad/ftbbs600x60.swf"" quality=""high"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" type=""application/x-shockwave-flash"" width=""600"" height=""60""></embed></object>" '147
adnl = "document.write('" & adnl & "')" '148
End If '149
rs.Close ( ) '150
bbsadurl = "../sitead.js" '151
SaveToFile ( adnl , bbsadurl ) '152
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog("E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP sitead:" & Err.Description)
Resume Next
End Function
'E:\FTBBS_UTF8_7.0\UPLOAD\ADMIN\DHFUN.ASP
Function htmtop(ByRef ft )
On Error GoTo _AspToAspX_Err
Dim adtype
Dim adtitle
Dim adurl
Dim ad_h
Dim ad_w
Dim adstr
Dim adnl
Dim bbsadurl
sql = "select top 1 * from " & ft & "ftbbs_ad where adflag=0 and ad_p=2 and (adtype=2 or adtype=3) order by id desc" '155
rs = New ADODB.Recordset ( ) '156
rs.Open ( sql , conn , 3 , 1 ) '157
If Not rs.EOF Then '158
adtype = AspToAspX_CheckDBNull(rs.Fields ( "adtype" ) .Value) '159
adtitle = "../" & AspToAspX_CheckDBNull(rs.Fields ( "adtitle" ) .Value) '160
If AspToAspX_CheckDBNull ( InStr ( adtitle , "http://" ) ) > 0 Then '161
adtitle = AspToAspX_CheckDBNull(rs.Fields ( "adtitle" ) .Value) '162
End If '163
adurl = AspToAspX_CheckDBNull(rs.Fields ( "adurl" ) .Value) '164
ad_h = AspToAspX_CheckDBNull(rs.Fields ( "ad_h" ) .Value) '165
ad_w = AspToAspX_CheckDBNull(rs.Fields ( "ad_w" ) .Value) '166
If AspToAspX_CheckDBNull ( adtype ) = 2 Then '167
adstr = "<a href=" & adurl & " target=""_blank""><img src=" & adtitle & " width=" & ad_w & " height=" & ad_h & " border=""0""></a>" '168
adnl = "<table cellspacing=0 cellpadding=0 width=""980"" align=center border=0><tbody><tr>" '169
adnl = adnl & "<td height=" & ad_h + 10 & " width=120 align=""left""><a href=""/""><img src=""../images/tmlogo.gif"" width=""112"" height=""50""></a></td><td height=" & ad_h + 10 & " align=""right"">" '170
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -