<%Option Explicit%>
<%
Response.Buffer=True
'
'
' アイコン nbbs
' Version 0.9g
' Last Up Date 2004/02/26
'
' HP: Http://www.ngc-net.co.jp/atyan/index.asp
' Mail: atyan@mail.goo.ne.jp
'
'****************************
' その他設定設定
'****************************
Dim ver
' その他
ver = "0.9f"
'****************************
' パブリック変数宣言
'****************************
' 初期値
Public ini_bg_color,ini_bg_img,ini_te_color,ini_link_color,ini_font_color,ini_board_name
Public ini_bt_color,ini_board_color,ini_title_color,ini_hp_url,ini_ko_kiji
Public ini_com_tag,ini_icom_used,Icon_title_name_option,Icon_file_name_option
' クッキー値
Public cook_name,cook_url,cook_mail,cook_icon,cook_color,cook_pass
Public check_1,check_2,check_3,check_4,check_5,check_6,check_7,check_8,check_9
Public check_10,check_11,check_12,check_13,check_14
Public CounterHits,mode
'****************************
' 初期設定読み込み
'****************************
%>
<%
Call start()
' ************************
' ■■■ メイン 処理
' ************************
mode = Request("mode")
' データベース接続
Call head()
If mode <> "" then
Select Case mode
Case "add"
Call add()
Case "dell"
Call dell()
Case "admin"
Call admin()
Case "ress"
Call ress()
Case "admin_del"
Call Admin_Del()
Case "admin_start"
Call admin_start()
Case "image"
Call icon()
Case Else
Call main()
End Select
Else
Call main()
End If
Call foot()
' ************************
' ■■■ メイン記事表示
' ************************
Sub main()
Dim REAC,cnt,page,tmpCnt,RS,RSQLC,ReNRS,ReSQLC,h_id,varClr_No
Dim main_id,main_name,main_title,main_url,main_mail,main_comm,main_color,main_date,main_icon
Dim c_mail,c_url,bbhr,c_pass,strTitle
strtitle=""
varClr_No = Split(varColor,",")
' 記事入力フォーム呼び出し
Call kiji_from(h_id,strTitle)
Set REAC = Server.CreateObject("ADODB.Connection")
With REAC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 1
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
' ページ 初期処理
If Request.QueryString("cnt") = "" Then
cnt = 1
page = 1
Else
cnt = CInt(Request.QueryString("cnt"))
tmpCnt = cnt - page_cnt
page = CInt(Request.QueryString("page"))
End If
' 記事表示処理
If ini_ko_kiji <> "yes" Then
Set RS = Server.CreateObject("ADODB.Recordset")
RSQLC = "SELECT * FROM [log] WHERE ([parent] =0) ORDER BY id DESC"
RS.Open RSQLC,REAC,3,2
Else
Set RS = Server.CreateObject("ADODB.Recordset")
RSQLC = "SELECT * FROM [log] WHERE ([parent] =0) ORDER BY update DESC"
RS.Open RSQLC,REAC,3,2
End IF
' データが無いときは処理を飛ばす
If not RS.EOF then
RS.AbsolutePosition = cnt
Do While Not RS.EOF
main_id = RS.Fields("id")
main_name = RS.Fields("name")
main_title = RS.Fields("title")
main_url = RS.Fields("url")
main_mail = RS.Fields("mail")
main_comm = RS.Fields("comment")
main_color = RS.Fields("color")
main_date = RS.Fields("sdate")
main_icon = RS.Fields("icon")
' メール、HP表示 処理
If main_url <> "http://" Then
c_url = "[ HP ]"
Else
If main_url = "http://" Then
c_url = ""
End If
End If
If main_mail <> "no mail" Then
c_mail = "" & main_name & ""
Else
c_mail = main_name
End If
' アイコン処理
If ini_icom_used = "yes" Then
If main_icon <> "" Then
main_icon = ""
End If
Else
main_icon = ""
End If
%>
<%
bbhr = "yes"
Set ReNRS = Server.CreateObject("ADODB.Recordset")
ReSQLC = "SELECT * FROM [log] WHERE ([parent]=" & main_id& ") ORDER BY id ASC"
ReNRS.Open ReSQLC,REAC,3,1
Do While Not ReNRS.EOF
main_id = ReNRS.Fields("id")
main_name = ReNRS.Fields("name")
main_title = ReNRS.Fields("title")
main_url = ReNRS.Fields("url")
main_mail = ReNRS.Fields("mail")
main_comm = ReNRS.Fields("comment")
main_color = ReNRS.Fields("color")
main_date = ReNRS.Fields("sdate")
main_icon = ReNRS.Fields("icon")
' メール、HP表示 処理
If main_url <> "http://" Then
c_url = "[ HP ]"
Else
If main_url = "http://" Then
c_url = ""
End If
End If
If main_mail <> "no mail" Then
c_mail = "" & main_name & ""
Else
c_mail = main_name
End If
' アイコン処理
If ini_icom_used = "yes" Then
If main_icon <> "" Then
main_icon = ""
End If
Else
main_icon = ""
End If
If bbhr = "yes" Then
Response.Write ""
End If
%>
<%
RS.MoveNext
cnt = cnt + 1
If cnt = page * page_cnt + 1 Then
Exit Do
End If
Loop
ReNRS.Close
Set ReNRS = Nothing
Else
Response.Write "
データがありません
"
End if
' ページ処理
Response.Write "
"
If page > 1 Then
Response.Write "[ 前へ ] "
End If
If Not RS.EOF Then
Response.Write "[ 次へ ]"
End If
Response.Write "
"
RS.Close
Set RS = Nothing
REAC.Close
Set REAC = Nothing
%>
<%
End Sub
' ************************
' ■■■ ヘッダー処理
' ************************
Sub head()
Response.Charset = "Shift_JIS"
' ■■■ カウンター処理
Dim ObjCounterFile, ReadCounterFile, WriteCounterFile
Dim CounterFile
Set ObjCounterFile = Server.CreateObject("Scripting.FileSystemObject")
CounterFile = Server.MapPath ("counter.txt")
Set ReadCounterFile= ObjCounterFile.OpenTextFile (CounterFile, 1, True)
If Not ReadCounterFile.AtEndOfStream Then
CounterHits = Trim(ReadCounterFile.ReadLine)
If CounterHits = "" Then
CounterHits = 0
End If
Else
CounterHits = 0
End If
ReadCounterFile.Close
Set ReadCounterFile = Nothing
If mode = "" Then
CounterHits = CounterHits + 1
End If
Set WriteCounterFile= ObjCounterFile.CreateTextFile (CounterFile, True)
WriteCounterFile.WriteLine(CounterHits)
WriteCounterFile.Close
Set WriteCounterFile = Nothing
Set ObjCounterFile = Nothing
%>
<%= ini_board_name %>
<%
If ini_icom_used = "yes" Then
%>
<%
End If
%>
<%= ini_board_name %> かならず「あこちゃん」から返信しますので、何でもいいから書いてね。
[ TOP ] [ HPへ戻る ] [ 管理用 ] [ Now: <%= Right("0" & CounterHits,7) %>Hits! ]
<%
End Sub
' ************************
' ■■■ フッダー処理
' ************************
Sub foot()
%>
<%
End Sub
' ************************
' ■■■ 記事 書き込み処理
' ************************
Sub add()
Dim n_par,n_name,n_title,n_comm,n_mail,n_url,n_pass,n_col,n_icon
Dim d_mail,n_date,n_main,n_ip,last_update
Dim AC,RC,SQLC,IRS,iip_SQL,CounterHits,REGX,FLAGS
' 入力データを受け取ります
n_par = Request.Form("parent")
n_name = Request.Form("name")
n_title = Request.Form("title")
n_comm = Request.Form("comment")
n_mail = Request.Form("mail")
n_url = Request.Form("url")
n_pass = Request.Form("passwd")
n_col = Request.Form("color")
n_icon = Request.Form("icon")
n_ip = Request.Form("ip")
If n_par = "" Then
n_par = 0
End If
' 名前 空白チェック
If n_name = "" Then
Response.Write "
"
Response.End
End If
' クッキーを 入れます
Response.Cookies("nbbsIcon")("Iconnbbsname") = n_name
Response.Cookies("nbbsIcon")("Iconnbbsurl") = n_url
Response.Cookies("nbbsIcon")("Iconnbbsmail") = n_mail
Response.Cookies("nbbsIcon")("Iconnbbscolor")= n_col
Response.Cookies("nbbsIcon")("Iconnbbspass") = n_pass
Response.Cookies("nbbsIcon").Expires = DATE + 30
Response.Cookies("nbbsIcon")("Iconnbbsicon") = n_icon
' タイトルチェック
If n_title = "" then
n_title = "の〜たいとる"
end If
' メール 正誤チェック
If n_mail <> "" Then
Set REGX = New RegExp
With REGX
.Global = True
.IgnoreCase = True
.Pattern = "[\w\.-]+(\+[\w-]*)?@([\w-]+\.)+[\w-]+"
FLAGS = REGX.Test(n_mail)
If FLAGS = False Then
n_mail = ""
End If
End With
Set REGX = Nothing
Else
n_mail = "no mail"
End If
If n_mail <> "" Then
d_mail = LCase(n_mail) '小文字変換
Else
d_mail = n_mail
End If
If n_url = "" Then
n_url = "http://"
End If
' タグ使用許可
If ini_com_tag <> "yes" Then
n_comm = Server.HTMLEncode(n_comm)
End If
n_comm = Replace(n_comm,Chr(13) & Chr(10)," ")
n_date = Formatdatetime(Date,1) & Formatdatetime(Now,3)
n_ip = Request.ServerVariables("REMOTE_ADDR")
' 最終投稿日 更新処理
If n_par = 0 Then
last_update = Now
Else
last_update = 0
End If
Set AC = Server.CreateObject("ADODB.Connection")
With AC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 3
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
Application.Lock
Set RC = Server.CreateObject("ADODB.Recordset")
SQLC = "SELECT TOP 1 * FROM [log] ORDER BY [ID] DESC"
RC.Open SQLC,AC,3,2
RC.AddNew
RC.Fields("parent") = n_par
RC.Fields("name") = n_name
RC.Fields("title") = n_title
RC.Fields("url") = n_url
RC.Fields("mail") = d_mail
RC.Fields("comment") = n_comm
RC.Fields("sdate") = n_date
RC.Fields("passwd") = n_pass
RC.Fields("color") = n_col
RC.Fields("icon") = n_icon
RC.Fields("update") = last_update
RC.Fields("ip") = n_ip
RC.Update
RC.Close
Set RC = Nothing
If ini_ko_kiji = "yes" Then
If n_par <> 0 Then
Set IRS = Server.CreateObject("ADODB.Recordset")
IIP_SQL = "SELECT TOP 1 * FROM [log] WHERE [ID] = " & n_par
IRS.Open IIP_SQL,AC,3,2
IRS.Fields("update") = Now
IRS.update
IRS.Close
Set IRS = Nothing
End If
End If
AC.Close
Set AC = Nothing
Application.Unlock
Response.Redirect asp_name
End Sub
' ************************
' ■■■ 削除処理
' ************************
Sub dell()
Dim up_num,u_pass
Dim AC,SQL,SQL2,SQL3,NRS
up_num = Request.Form("up_num")
u_pass = Request.Form("up_pass")
If up_num = "" or u_pass = "" Then
Response.Write "
"
Response.Write "
削除No、もしくはパスワードが未入力です。
"
Response.Write "
"
Response.Write "
= 前のページへ戻る ="
Response.End
End If
Set AC = Server.CreateObject("ADODB.Connection")
With AC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 3
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
SQL ="SELECT * FROM [log] WHERE id=" & up_num
Set NRS = AC.Execute(SQL)
If u_pass = NRS("passwd") Then
Application.Lock
SQL2 = "DELETE * FROM [log] WHERE ID=" & up_num
AC.Execute(SQL2)
SQL3 = "DELETE * FROM [log] WHERE parent=" & up_num
AC.Execute(SQL3)
Application.Unlock
Else
NRS.Close
Response.Write "
"
Response.Write "
パスワードが違います。
"
Response.Write "
"
Response.Write "
= 前のページへ戻る ="
Response.End
End If
NRS.Close
Set NRS = Nothing
AC.Close
Set AC = Nothing
Response.Write "
"
Response.End
End Sub
' ************************
' ■■■ 管理者 削除
' ************************
Sub admin()
Dim up_pass
If Request.Form("up_pass") = pass_word Then
Session("pass") = Request.Form("up_pass")
End If
If Session("pass") <> pass_word Then
%>
<%
Else
Dim REAC,cnt,page,RS,RSQLC,ReNRS,ReSQLC
Dim main_id,main_name,main_title,main_url,main_mail,main_comm,main_date,main_ip
Dim c_mail,c_url,c_pass
Dim admin_cnt,admin_page,admin_tmpCnt
Set REAC = Server.CreateObject("ADODB.Connection")
With REAC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 1
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
' ページ 初期処理
If Request.QueryString("admin_cnt") = "" Then
admin_cnt = 1
admin_page = 1
Else
admin_cnt = CInt(Request.QueryString("admin_cnt"))
admin_tmpCnt = admin_cnt - page_cnt
admin_page = CInt(Request.QueryString("admin_page"))
End If
%>
<%
' ページ処理
Response.Write "
"
If admin_page > 1 Then
Response.Write "[ 前へ ] "
End If
If Not RS.EOF Then
Response.Write "[ 次へ ]"
End If
Response.Write "
"
RS.Close
Set RS = Nothing
REAC.Close
Set REAC = Nothing
End If
End Sub
' ************************
' ■■■ 管理者 削除処理
' ************************
Sub Admin_Del()
Dim delno,del_cnt,del_itm,del_spl,i,AC,SQL,SQL2
If Session("pass") = pass_word Then
If Request.Form("delno") <> "" Then
del_cnt = Request.Form("delno").Count
del_itm = Request.Form("delno")
del_spl = Split(del_itm,",",-1)
Set AC = Server.CreateObject("ADODB.Connection")
With AC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 3
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
For i = 0 to del_cnt-1
SQL = "DELETE * FROM log WHERE id=" & del_spl(i)
AC.Execute(SQL)
SQL2 = "DELETE * FROM log WHERE parent=" & del_spl(i)
AC.Execute(SQL2)
Next
AC.Close
Set AC = Nothing
%>
"
Response.Write "掲示板へ戻る"
End If
End Sub
' ************************
' ■■■ 返信記事 入力
' ************************
Sub ress()
Dim h_id,AC,NRS,SQL,ReNRS,ReSQLC
Dim main_name,main_url,main_mail,main_color,main_icon,main_id,main_title
Dim c_url,c_mail,bbhr
Dim mai_id,mai_name,mai_title,mai_url,mai_mail,mai_comm,mai_color,mai_date
%>
<%
h_id = Request("id")
Set AC = Server.CreateObject("ADODB.Connection")
With AC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 3
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
SQL="SELECT * FROM [log] WHERE id=" & h_id &""
Set NRS=AC.Execute(SQL)
main_name = NRS.Fields("name")
main_id = NRS.Fields("ID")
main_url = NRS.Fields("url")
main_mail = NRS.Fields("mail")
main_title = NRS.Fields("title")
main_color = NRS.Fields("color")
main_icon = NRS.Fields("icon")
' メール、HP表示 処理
If main_url <> "http://" Then
c_url = "[ HP ]"
Else
If main_url = "http://" Then
c_url = ""
End If
End If
If main_mail <> "no mail" Then
c_mail = "" & main_name & ""
Else
c_mail = main_name
End If
%>
<%
bbhr = "yes"
Set ReNRS = Server.CreateObject("ADODB.Recordset")
ReSQLC = "SELECT * FROM [log] WHERE ([parent]=" & main_id& ") ORDER BY ID ASC"
ReNRS.Open ReSQLC,AC,3,1
Do While Not ReNRS.EOF
mai_id = ReNRS.Fields("ID")
mai_name = ReNRS.Fields("name")
mai_title = ReNRS.Fields("title")
mai_url = ReNRS.Fields("url")
mai_mail = ReNRS.Fields("mail")
mai_comm = ReNRS.Fields("comment")
mai_color = ReNRS.Fields("color")
mai_date = ReNRS.Fields("sdate")
' メール、HP表示 処理
If mai_url <> "http://" Then
c_url = "[ HP ]"
Else
If mai_url = "http://" Then
c_url = ""
End If
End If
If mai_mail <> "no mail" Then
c_mail = "" & mai_name & ""
Else
c_mail = mai_name
End If
If bbhr = "yes" Then
Response.Write ""
End If
%>
"
Response.Write "掲示板へ戻る"
End If
End Sub
' ************************
' ■■■ アイコン一覧表示
' ************************
Sub icon()
Dim icon_cnt_01,icon_cnt_02,Icon_file_name,Icon_title_name,img_cnt
%>
アイコン画像 一覧
<%
Icon_file_name = Split(stricon,"<>")
Icon_title_name = Split(icon_name,"<>")
' アイコン数を取得する
For icon_cnt_01 = 0 to (UBound(Icon_title_name)/8)
Response.Write "
"
For icon_cnt_02 = 1 to 8
If ((icon_cnt_01*8)+(icon_cnt_02))-1 => UBound(Icon_title_name) Then
Exit For
Else
Response.Write "
"
End Sub
' ************************
' ■■■ 初期設定読込
' ************************
Sub Start()
Dim AC,RS,SQL
Set AC = Server.CreateObject("ADODB.Connection")
With AC
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Mode = 1
.ConnectionString = Server.MapPath(mdb_pass & mdb_name)
.Open
End With
Set RS = Server.CreateObject("ADODB.Recordset")
SQL = "SELECT * FROM [admin] WHERE ([ID] =1)"
RS.Open SQL,AC,3,2
ini_bg_color = RS.Fields("body_color")
ini_te_color = RS.Fields("body_text")
ini_link_color = RS.Fields("body_link")
ini_bg_img = RS.Fields("body_img")
ini_board_name = RS.Fields("bbs_name")
ini_font_color = RS.Fields("bbs_font_color")
ini_bt_color = RS.Fields("bbs_title_color")
ini_board_color = RS.Fields("bbs_border_color")
ini_title_color = RS.Fields("bbs_comment_color")
ini_hp_url = RS.Fields("bbs_home_url")
ini_ko_kiji = RS.Fields("bbs_kokiji")
ini_com_tag = RS.Fields("bbs_tag")
ini_icom_used = RS.Fields("bbs_icon_use")
' データがNullの場合 空白を入れます
IF TypeName(ini_bg_color) = "Null" Then
ini_bg_color = ""
End if
If TypeName(ini_te_color) = "Null" Then
ini_te_volor = ""
End if
If TypeName(ini_link_color) = "Null" Then
ini_link_color = ""
End if
If TypeName(ini_bg_img) = "Null" Then
ini_bg_img = ""
End if
If TypeName(ini_board_name) = "Null" Then
ini_board_name = ""
End if
If TypeName(ini_font_color) = "Null" Then
ini_font_color = ""
End if
If TypeName(ini_bt_color) = "Null" Then
ini_bt_color = ""
End if
If TypeName(ini_board_color) = "Null" Then
ini_board_color = ""
End if
If TypeName(ini_title_color) = "Null" Then
ini_title_color = ""
End if
If TypeName(ini_hp_url) = "Null" Then
ini_hp_url = ""
End if
If TypeName(ini_ko_kiji) = "Null" Then
ini_ko_kiji = "yes"
End if
If TypeName(ini_com_tag) = "Null" Then
ini_com_tag = "yes"
End if
If TypeName(ini_icom_used) = "Null" Then
ini_icom_used = "yes"
End if
RS.Close
Set RS = Nothing
AC.Close
Set AC = Nothing
End Sub
' ************************
' ■■■ 記事入力フォーム
' ************************
Sub kiji_from(h_id,strTitle)
' クッキーを頂きます
cook_name = Request.Cookies("nbbsIcon")("Iconnbbsname")
cook_url = Request.Cookies("nbbsIcon")("Iconnbbsurl")
cook_mail = Request.Cookies("nbbsIcon")("Iconnbbsmail")
cook_icon = Request.Cookies("nbbsIcon")("Iconnbbsicon")
cook_color = Request.Cookies("nbbsIcon")("Iconnbbscolor")
cook_pass = Request.Cookies("nbbsIcon")("Iconnbbspass")
Dim i_cnt
Dim icon_file_22,strTitle_res
If strTitle <> "" Then
strTitle_res = "Res:" & Left(strTitle,12)
Else
strTitle_res = ""
End If
Dim cook_clrVal,varClr_No,i
varClr_No = Split(varColor,",")
ReDim cook_clrVal(Int(UBound(varClr_No)))
' 色 クッキー
If cook_color <> "" Then
cook_clrVal(cook_color) = "checked"
else
cook_clrVal(0) = "checked"
End If
%>
<%
End Sub
%>