 |
  |
 |
 |
 |
|
|
 |
|
|
<%
Dim TREECOLOR1
Dim TREECOLOR2
Dim VIEWCOLOR1
Dim VIEWCOLOR2
Dim VIEWCOLOR3
Dim MENUBARCOLOR
Dim BODY
Dim TBL_NAME_BIYOU
Dim PAGE_STR
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Provider = "Microsoft.Jet.OLEDB.4.0"
Conn.ConnectionString = DB_FILE
Conn.Open
ViewPos=0
POS=0
MAX=10
TODAY_DATE = Year(Now()) & "/" & Month(Now()) & "/" & Day(Now())
TODAY_TIME = Hour(Time) & ":" & Minute(Time)
DATE_TIME = TODAY_DATE & " " & TODAY_TIME
If request("NAME") <> "" Then
NAME = request("NAME")
Else
NAME =""
End If
If request("MAIL") <> "" Then
MAIL = request("MAIL")
Else
MAIL = "none"
End If
If request("DKEY") <> "" Then
DKEY = request("DKEY")
Else
DKEY = "none"
End If
If request("SUBJECT") <> "" Then
SUBJECT = request("SUBJECT")
Else
SUBJECT = ""
End If
If request("COMMENT") <> "" Then
COMMENT = request("COMMENT")
If COMMENT<>"" Then
Link_Judge
End if
cod=""
For i=1 To LenB(COMMENT)
co = Mid(COMMENT,i,1)
If co = chr(13) Then
cod = cod & " " ENd IF cod = cod & co Next COMMENT = cod Else COMMENT = "" End If MODE = request("MODE") BBSColorSet 2 Header If MODE = "" Then FormMain TreeMain( TRUE ) response.write PAGE_STR End If If MODE = "ADDNEW" Then BBSAdd End If If MODE = "DEL" Then If request("DKEY") <> "" Then DKEY = request("DKEY") Else DKEY = "" End If If DKEY = ADMIN_PASS Then BBSDel_ADMIN else BBSDel End If End If If MODE = "VIEW" Then BBSView End If If MODE = "RES" Then BBSRes End If Fuder Conn.Close '*-----------------------------------------------------------------------* ' ヘッダー部 '*-----------------------------------------------------------------------* Sub Header() response.write "" & vbCRLF response.write BODY & vbCRLF response.write "
" & chr(13) MOVE_STR2 = "" & chr(13) PAGE_STR = "
登録しました。 " else response.write "
" response.write "" END IF response.write " " response.write "戻る" End Sub '*-----------------------------------------------------------------------* ' 発言の削除 '*-----------------------------------------------------------------------* Sub BBSDel() ID = request("ID") If DKEY <> "" Then SQL = "SELECT DKEY FROM " & TBL_NAME_BIYOU SQL = SQL & " WHERE ID = " & ID Set rst = Conn.Execute(sql) IF DKEY = "4324" Then RST.CLOSE SQL="UPDATE " & TBL_NAME_BIYOU & " SET DEL_FLG = 1 WHERE ID=" & ID Set rst = Conn.Execute(sql) response.write " 削除しました。 " ELSEIF RST("DKEY")<>DKEY THEN response.write " 入力された削除キーが一致しません。 " ELSE RST.CLOSE SQL="UPDATE " & TBL_NAME_BIYOU & " SET DEL_FLG = 1 WHERE ID=" & ID & " AND DKEY='" & DKEY & "'" ' response.write sql 'response.end Set rst = Conn.Execute(sql) response.write " 削除しました。 " END IF ELSE response.write " 削除キーを入力して下さい。 " END IF response.write " " response.write "戻る" End Sub '*-----------------------------------------------------------------------* ' 管理者によるデータ物理削除 '*-----------------------------------------------------------------------* Sub BBSDel_ADMIN() sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE ID="& request("ID") Set rst = Conn.Execute(sql) if not rst.EOF then DEL_ID=rst("ID") DEL2( rst("ID") ) SQL = "DELETE FROM " & TBL_NAME_BIYOU SQL = SQL & " WHERE ID = " & DEL_ID Set rst = Conn.Execute(sql) End If response.write " 管理者削除しました。 " response.write " " response.write "戻る" ' rst.Close End Sub '*-----------------------------------------------------------------------* ' 発言Tree表示(親の展開) ' 引数：ID ' =親のID番号 '*-----------------------------------------------------------------------* Sub DEL2( ID ) sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE GID=" & ID ' & " ORDER BY ID DESC" Set rst = Conn.Execute(sql) Do UNTIL rst.EOF DEL_ID=rst("ID") DEL2( rst("ID") ) SQL = "DELETE FROM " & TBL_NAME_BIYOU SQL = SQL & " WHERE ID = " & DEL_ID Set rst2 = Conn.Execute(sql) rst.MoveNext LOOP ' rst.Close End Sub '*-----------------------------------------------------------------------* ' レス '*-----------------------------------------------------------------------* Sub BBSRes() If NAME <> "" And SUBJECT <> "" And COMMENT <> "" Then sql="INSERT INTO " & TBL_NAME_BIYOU & "(NAME,MAIL,SUBJECT,COMMENT,DATE_TIME,DKEY,GID,DEL_FLG) VALUES ('" & NAME & "','" & MAIL & "','" & SUBJECT & "','" & COMMENT & "','" & DATE_TIME & "','" & DKEY & "'," & request("ID") & ",0)" Set rst = Conn.Execute(sql) Else sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE ID=" & request("ID") Set rst = Conn.Execute(sql) RESSUB = "Re:" & rst("SUBJECT") response.write " " & chr(13) response.write "
" & chr(13) response.write " " & chr(13) response.write "上記書き込みへのRES" & chr(13) rst.Close End If If NAME <> "" And SUBJECT <> "" And COMMENT <> "" Then response.write " 登録しました。 " Else response.write " " End If response.write "" response.write "戻る" End Sub '*-----------------------------------------------------------------------* ' 発言表示 '*-----------------------------------------------------------------------* Sub BBSView() sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE ID=" & request("ID") & " AND DEL_FLG=0" Set rst = Conn.Execute(sql) RESSUB = "Re:" & rst("SUBJECT") response.write " " & chr(13) response.write "
" & chr(13) response.write " " & chr(13) response.write "" response.write "上記書き込みへコメントする" & chr(13) response.write " " & chr(13) 'If rst("DKEY") <> "none" Then response.write "
" response.write "" response.write "" End Sub '*-----------------------------------------------------------------------* ' 発言Tree表示 ' 引数：All ' TRUE = Tree表示 ' FALSE = 親のみ表示 '*-----------------------------------------------------------------------* Sub TreeMain( All ) sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE DEL_FLG=0 and GID=0 ORDER BY ID DESC" Set rst = Conn.Execute(sql) response.write " " & chr(13) ViewNo=0 If POS <> 0 Then rst.Move POS End If Do UNTIL rst.EOF response.write "
" rst.MoveNext rstCount = rstCount + 1 If rstCount = MAX Then Exit Do End If LOOP response.write " " & chr(13) rst.Close End Sub '*-----------------------------------------------------------------------* ' 発言Tree表示(親の展開) ' 引数：ID ' =親のID番号 '*-----------------------------------------------------------------------* Sub TreeView( ID ) sql="SELECT * FROM " & TBL_NAME_BIYOU & " WHERE GID=" & ID ' & " ORDER BY ID DESC" Set rst = Conn.Execute(sql) Do UNTIL rst.EOF response.write " " For j=0 to ViewPos response.write " " next IF RST("DEL_FLG")="0" Then response.write "" response.write "  "
response.write ""
response.write ""
response.write " " & rst("SUBJECT") & ""
response.write " "
If rst("MAIL") <> "none" Then
response.write ""
response.write " "
response.write ""
End If
response.write " " & rst("NAME") & "さん"
If TODAY_DATE = Left(rst("DATE_TIME"),Len(TODAY_DATE)) Then
response.write " [Today! " & rst("DATE_TIME") & "]"
Else
response.write " [" & rst("DATE_TIME") & "]"
End If
response.write " #" & rst("ID") & "."
response.write "" & chr(13) For j=0 to ViewPos response.write " " next response.write rst("COMMENT") & chr(13) ELSE response.write " "
response.write "投稿者によって削除されました。"
response.write "" & chr(13) END IF ViewPos=ViewPos+1 TreeView( rst("ID") ) ViewPos=ViewPos-1 rst.MoveNext LOOP rst.Close End Sub Sub Link_Judge() If (Instr(1,COMMENT,"http://") > 0 or Instr(1,COMMENT,"ftp://") > 0 or Instr(1,COMMENT,"mailto:") > 0) and InStr(1,COMMENT,"<") = 0 Then COMMENT = Replace(COMMENT,"__URL__","") flg = 0 chatcp = "" urlcp = "" for i = 1 to len(COMMENT) j = Mid(COMMENT,i,1) Select Case UCase(j) Case "A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z","1","2","3","4","5","6","7","8","9","0","$","@","/","%",".","_","-","~","#","&","=","l",":","?" if Mid(COMMENT,i,7) = "http://" or Mid(COMMENT,i,6) = "ftp://" or Mid(COMMENT,i,7) = "mailto:" then if flg = 1 then chatcp = Replace(COMMENT,"__URL__",urlcp) chatcp = chatcp & "" urlcp = "" end if if Mid(COMMENT,i,7) = "mailto:" then chatcp = chatcp & "" else chatcp = chatcp & "" end if flg = 1 end if if flg = 1 then urlcp = urlcp & Mid(COMMENT,i,1) end if Case else if flg = 1 then chatcp = Replace(chatcp,"__URL__",urlcp) chatcp = chatcp & "" flg = 0 urlcp = "" end if End Select chatcp = chatcp & j next if flg = 1 then chatcp = Replace(chatcp,"__URL__",urlcp) chatcp = chatcp & "" end if COMMENT = chatcp end if End Sub %> |
|
新規発言"
response.write "
"
response.write "新規登録
メールはこちらへ
"
response.write " No." & right("0000" & rst("ID"),4) & "."
response.write "
