" & Wk_title & "

<% '*-----------------------------------------------------------------------------* ' 設定変更可能 '*-----------------------------------------------------------------------------* Wk_autobr = 1 ' 。！？で自動改行（0=しない 1=する） Wk_title = "マブイの旅BBS" ' Title名 Wk_script = "aspbbs2.asp" ' スクリプト名(ファイル名) Wk_logfile = "aspbbs2.log" ' ログファイル名 Wk_pass = "film2696" ' 管理者用パスワード Wk_max = 300 ' 最大Log数（これを超える記事は古い順に削除されます） Wk_home = "index.html" ' 戻り先 Wk_Bgcolor = "#E6E6E6" ' メッセージ表示枠内の色 Wk_Textcolor = "#003300" ' テキストの色 Wk_TitleColor = "#990000" ' タイトルの色 Wk_AdminBgcolor = "#CCCCCC" ' 管理者メッセージの見出しの色 Wk_body = "" Wk_tagkey = 0 ' タグ許可 (0=no 1=yes) Wk_autolink = 1 ' URLの自動リンク (0=no 1=yes)※タグ許可の場合は (0=no) とすること。 Wk_sort_flg = 1 ' 最新記事をTopに表示する(0=no 1=yes) Wk_p_log = 10 ' １ページあたりの親記事表示数 Wk_res = 0 ' 返信機能 (0=有り 1=無し) Wk_find = 0 ' 検索機能 (0=有り 1=無し) Wk_acnt = 0 ' アクセスカウント機能 (0=有り 1=無し) Wk_entrymode = 0 ' 登録画面を（0=Topに表示 1=登録専用画面に表示する） 'Basp21が使える場合のみ利用できます Wk_mailing = 0 ' メール通知機能（0=しない 1=投稿全て 2=管理者以外の投稿） Wk_mailto = "***@***.com" ' メール通知先アドレス（メール通知する場合） Wk_smtpsrv = "***.***.com" ' SMTPサーバーの指定 Dim Wk_nohost(10) Wk_nohost(0) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(1) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(2) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(3) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(4) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(5) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(6) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(7) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(8) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(9) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Wk_nohost(10) = "***.***.***.***" ' ホストアドレスによるアクセス制限（ホストアドレスを記述） Dim Wk_noAgent(5) Wk_noAgent(0) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_noAgent(1) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_noAgent(2) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_noAgent(3) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_noAgent(4) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_noAgent(5) = "D-Engine" ' 自動書き込みソフトのアクセス制限 Wk_ImgTitle = "http://www.film-izmax.com/mabui/img_tit.gif" ' Titleに画像を使用する場合 (http://から画像を指定) Wk_ImgWidth = "339" ' Titleに画像を使用する場合に「横」のピクセル数 Wk_ImgHight = "67" ' Titleに画像を使用する場合に「縦」のピクセル数 ' '*-----------------------------------------------------------------------------* ' 設定変更可能ここまで '*-----------------------------------------------------------------------------* Dim Wk_AllLog_array() ReDim Preserve Wk_AllLog_array(Wk_Max - 1) Dim Wk_mode Dim Wk_tno Dim Wk_admes Dim Wk_no Dim Wk_reno Dim Wk_date Dim Wk_name Dim Wk_mail Dim Wk_sub Dim Wk_mes Dim Wk_url Dim Wk_host Dim Wk_TopCnt Dim Wk_pwd Dim Wk_flg Dim Wki_word Dim Wki_cond Dim Wki_no Dim Wki_reno Dim Wki_pwd Dim Wki_pwd2 ' クッキー用 Dim Wki_name Dim Wki_email Dim Wki_sub Dim Wki_mes Dim Wki_url Dim Wki_pass Dim Wki_res Dim Cnt_All Dim Cnt_Today Dim Cnt_Yesterday Dim Wk_User_Agent Wk_ver = "copyright(c)2002Y'creative" Wk_Lockfile = "lock.dat" Wk_LockAfile = "Alock.dat" ' '*-----------------------------------------------------------------------------* '　コントロール処理 '*-----------------------------------------------------------------------------* Call decode Call access_check If Wk_acnt = 0 Then Call AccessCount() End If Select Case Wk_mode Case "entry" Call entry Case "regist" Call regist Case "userdel" Call userdel Case "del" Call del_msg Case "find" Call find Case "admin" Call admin End Select Call LogView ' '*-----------------------------------------------------------------------------* ' アクセス制限 '*-----------------------------------------------------------------------------* Sub access_check() If Wk_nohost(0) <> "" Then Call get_host ' ホストアドレスを取得 Wk_flag = 0 For Each Wkl_nohost In Wk_nohost If Wkl_nohost = "" Then Exit For End If If Wkl_nohost = Wk_host Then Wk_flag = 1 Exit For End If Next If Wk_flag = 1 Then Call error(Wk_host & "
上記アドレスの
アクセスを拒否します。") End If End If '--- 自動書き込みソフトのアクセス制限 If Wk_noAgent(0) <> "" Then Wk_flag = 0 For Each Wkl_noAgent In Wk_noAgent If Wkl_noAgent = "" Then Exit For End If If Instr(Wk_User_Agent,Wkl_noAgent) > 0 Then Wk_flag = 1 Exit For End If Next If Wk_flag = 1 Then Call error("自動書込みｿﾌﾄの
アクセスを拒否します。") End If End If End Sub ' '*-----------------------------------------------------------------------------* ' Log表示処理 '*-----------------------------------------------------------------------------* Sub LogView() Call header Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "[Topに戻る] " & vbCRLF If Wk_entrymode = 1 Then Response.Write "[新規に書込] " & vbCRLF End If If Wk_find = 0 Then Response.Write "[検索] " & vbCRLF End If Response.Write "[削除] " & vbCRLF Response.Write "[管理者]" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF If Wk_entrymode = 0 Then Call entry2() End If Response.Write "

" & vbCRLF ' 改ページ用処理 Wk_start = CInt(Wk_TopCnt) + 1 Wk_end = CInt(Wk_TopCnt) + CInt(Wk_p_log) read_data() If Wk_admes <> "" Then ' 管理者からのメッセージ処理 Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "

" Response.Write "■管理者からのメッセージ
" Response.Write "

" Response.Write "

" Response.Write Wk_admes Response.Write "

" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF End If Wk_Ix = 0 For Each Wkl_AllLog In Wk_AllLog_array Wkl_AllLog_array = split(Wkl_AllLog,"<>") If UBound(Wkl_AllLog_array) >= 10 Then Wk_no = Wkl_AllLog_array(0) Wk_reno = Wkl_AllLog_array(1) Wk_date = Wkl_AllLog_array(2) Wk_name = Wkl_AllLog_array(3) Wk_mail = Wkl_AllLog_array(4) Wk_sub = Wkl_AllLog_array(5) Wk_mes = Wkl_AllLog_array(6) Wk_url = Wkl_AllLog_array(7) Wk_host = Wkl_AllLog_array(8) Wk_pwd = Wkl_AllLog_array(9) Wk_User_Agent = Wkl_AllLog_array(10) Else Exit For End If If Wk_reno = "" Then Wk_Ix = Wk_Ix + 1 End If If (Wk_Ix < Wk_start) or (Wk_Ix > Wk_end) Then Wkl_AllLog_array = split(Wkl_AllLog,"<>") If UBound(Wkl_AllLog_array) < 8 Then Wk_Ix = Wk_Ix - 1 Exit For End If Else Call DetailsView() ' 明細表示 End If Next ' 特別処理（タグ閉じ　ミス　防止） Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Wk_Next_top = CInt(Wk_TopCnt) + Wk_p_log Wk_back_top = CInt(Wk_TopCnt) - Wk_p_log If ((Wk_back_top >= 0) or (Wk_Next_top < Wk_ix)) Then Response.Write "

" & vbCRLF End If Response.Write "" Response.Write "" Response.Write "" Response.Write "

" Response.Write "" If Wk_back_top >= 0 Then Response.Write "" End If If Wk_Next_top < Wk_Ix Then Response.Write "" End If Response.Write "

" Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' 新規書込　及び　返信書込　の編集及び表示 '*-----------------------------------------------------------------------------* Sub entry() Wkc_name = Request.Cookies(Wk_script)("name") Wkc_email = Request.Cookies(Wk_script)("email") Wkc_url = Request.Cookies(Wk_script)("url") Wkc_pwd = Request.Cookies(Wk_script)("pwd") ' If Wki_res = "res" Then read_data() Wk_flag = 0 Wk_Ix = 0 For Each Wkl_AllLog In Wk_AllLog_array Wk_Ix = Wk_Ix + 1 Wkl_AllLog_array = split(Wkl_AllLog,"<>") If UBound(Wkl_AllLog_array) >= 10 Then Wk_no = Wkl_AllLog_array(0) Wk_reno = Wkl_AllLog_array(1) Wk_date = Wkl_AllLog_array(2) Wk_name = Wkl_AllLog_array(3) Wk_mail = Wkl_AllLog_array(4) Wk_sub = Wkl_AllLog_array(5) Wk_mes = Wkl_AllLog_array(6) Wk_url = Wkl_AllLog_array(7) Wk_host = Wkl_AllLog_array(8) Wk_pwd = Wkl_AllLog_array(9) Wk_User_Agent = Wkl_AllLog_array(10) End If If Wki_no = Wk_no Then Wk_flag = 1 Exit For End If Next ' If Wk_flag = 0 Then Call error("該当記事が見つかりません。") End If ' Wk_sub = Replace(Wk_sub,"^Re:","") Wk_r_sub = "Re:[" & Wk_no & "] " & Wk_sub Wk_r_mes = "> " & Wk_mes Wk_r_mes = Replace(Wk_r_mes,"&","&") Wk_r_mes = Replace(Wk_r_mes,"<","<") Wk_r_mes = Replace(Wk_r_mes,">",">") Wk_r_mes = Replace(Wk_r_mes,"
",vbcr & "> ") End If Call header ' Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "" If (Request.Querystring("res") = "res") Then Response.Write "★返信　書き込み★
" & vbCRLF Else Response.Write "★新規　書き込み★
" & vbCRLF End If Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF ' Response.Write "" Response.Write "" Response.Write "

" Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF Response.Write "" & vbCRLF If Wki_res = "res" Then Response.Write "" & vbCRLF Else Response.Write "" & vbCRLF End If Response.Write "
" & vbCRLF Response.Write "■名前(必須)
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "■題名
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "■メール
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "■URL
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "■内容(必須)
" & vbCRLF Response.Write " " & Wk_r_mes & "" & vbCRLF Response.Write "
" & vbCRLF Response.Write "■削除キー
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF If (Request.Querystring("res") = "res") Then Response.Write "

" & vbCRLF For Each Wkl_AllLog In Wk_AllLog_array Wkl_AllLog_array = split(Wkl_AllLog,"<>") If UBound(Wkl_AllLog_array) >= 10 Then Wk_no = Wkl_AllLog_array(0) Wk_reno = Wkl_AllLog_array(1) Wk_date = Wkl_AllLog_array(2) Wk_name = Wkl_AllLog_array(3) Wk_mail = Wkl_AllLog_array(4) Wk_sub = Wkl_AllLog_array(5) Wk_mes = Wkl_AllLog_array(6) Wk_url = Wkl_AllLog_array(7) Wk_host = Wkl_AllLog_array(8) Wk_pwd = Wkl_AllLog_array(9) Wk_User_Agent = Wkl_AllLog_array(10) Else Exit For End If If ((Wk_no = Wki_no) or (Wk_reno = Wki_no)) Then Call DetailsView() ' 明細表示 Else Wkl_AllLog_array = split(Wkl_AllLog,"<>") If UBound(Wkl_AllLog_array) < 8 Then Exit For End If End If Next Response.Write "" & vbCRLF ' 特別処理（タグ閉じ　ミス　防止） Response.Write "
" & vbCRLF End If Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' 新規書込　及び　返信書込　の編集及び表示 '*-----------------------------------------------------------------------------* Sub entry2() Wkc_name = Request.Cookies(Wk_script)("name") Wkc_email = Request.Cookies(Wk_script)("email") Wkc_url = Request.Cookies(Wk_script)("url") Wkc_pwd = Request.Cookies(Wk_script)("pwd") Response.Write "

" & vbCRLF Response.Write "

" Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "

" Response.Write "名前	" Response.Write "" Response.Write "" Response.Write "
" Response.Write "題名	" Response.Write "
" Response.Write "メール	" Response.Write "
" Response.Write "ＵＲＬ	" Response.Write "
内容
" Response.Write "" & Wk_r_mes & "
削除Key	" Response.Write " " Response.Write "

" Response.Write "

" End Sub ' '*-----------------------------------------------------------------------------* '　ユーザーによる削除処理 '*-----------------------------------------------------------------------------* Sub del_msg() Call header ' ヘッダを出力 ' Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "★　削　除　★
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF ' If Wki_no <> "" Then read_data() Wk_Ix = 0 For Each Wkl_Log In Wk_AllLog_array Wk_flag = 0 Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 7 Then Wk_no = Wkl_Log_array(0) Wk_reno = Wkl_Log_array(1) Wk_date = Wkl_Log_array(2) Wk_name = Wkl_Log_array(3) Wk_mail = Wkl_Log_array(4) Wk_sub = Wkl_Log_array(5) Wk_mes = Wkl_Log_array(6) Wk_url = Wkl_Log_array(7) Else Wk_no = "" Wk_reno = "" Wk_date = "" Wk_name = "" Wk_mail = "" Wk_sub = "" Wk_mes = "" Wk_url = "" End If If Wk_no = Wki_no Then Call DetailsView2() Response.Write "

" & vbCRLF Exit For End If Next End If Response.Write "" Response.Write "" Response.Write "

" Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF Response.Write "" & vbCRLF Response.Write "
" & vbCRLF If Request.Querystring("no") = "" Then Response.Write "■番号（必須）
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Else Response.Write " " & vbCRLF End If Response.Write "■削除キー（必須）
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write " " & vbCRLF Response.Write "
" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' 書きこみ処理 '*-----------------------------------------------------------------------------* Sub regist() If Wki_name = "" Then Call error("名前が入力されていません") End If If Wki_mes = "" Then Call error("内容が入力されていません") End If If Wki_email <> "" Then If MailCheck(Wki_email) = "ERR" Then Call error("メールアドレス間違えていませんか？") End If End If read_data() Wkl_AllLog_array = split(Wk_AllLog_array(0),"<>") If UBound(Wkl_AllLog_array) >= 6 Then Wkl_no = Wkl_AllLog_array(0) Wkl_reno = Wkl_AllLog_array(1) Wkl_date = Wkl_AllLog_array(2) Wkl_name = Wkl_AllLog_array(3) Wkl_mail = Wkl_AllLog_array(4) Wkl_sub = Wkl_AllLog_array(5) Wkl_mes = Wkl_AllLog_array(6) End If If (Wki_name = Wkl_name) AND (Wki_mes = Wkl_mes) Then Call error("二重投稿は禁止です") End If ' 再番用に特別処理（削除等で同じ番号がかぶらないように２倍でループ） If CInt(Wk_tno) >= (Wk_Max * 2) Then ' 記事Noを採番 Wk_no = CInt(1) Wk_tno = Wk_no Else Wk_no = Wk_tno + 1 Wk_tno = Wk_no End If Call get_host ' ホストアドレスを取得 ' 編集＆書き込み Wkl_write_data = Wk_no & "<>" Wkl_write_data = Wkl_write_data & Wki_reno & "<>" Wkl_write_data = Wkl_write_data & Wk_date & "<>" Wkl_write_data = Wkl_write_data & Wki_name & "<>" Wkl_write_data = Wkl_write_data & Wki_email & "<>" Wkl_write_data = Wkl_write_data & Wki_sub & "<>" Wkl_write_data = Wkl_write_data & Wki_mes & "<>" Wkl_write_data = Wkl_write_data & Wki_url & "<>" Wkl_write_data = Wkl_write_data & Wk_host & "<>" Wkl_write_data = Wkl_write_data & Wki_pwd & "<>" Wkl_write_data = Wkl_write_data & Wk_User_Agent & "<>" Wkl_write_data = Wkl_write_data & "<><>" write_data(Wkl_write_data) ' メール通知処理 If Wk_mailing = 1 Then Call send_mail Else If (Wk_mailing = 2) AND (Wki_email <> Wk_mailto) Then Call send_mail End If End If ' Response.Cookies(Wk_script)("name") = Wki_name Response.Cookies(Wk_script)("email") = Wki_email Response.Cookies(Wk_script)("url") = Wki_url Response.Cookies(Wk_script)("pwd") = Wki_pwd2 Response.Cookies(Wk_script).Expires = DateValue(DateAdd("d",30,GetdateString())) End Sub ' '*-----------------------------------------------------------------------------* ' ワード検索 '*-----------------------------------------------------------------------------* Sub find() ' Dim Wkf_AllLog_array() ReDim Preserve Wkf_AllLog_array(Wk_Max - 1) ' Call header Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "★　検　索　★
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Response.Write "■キーワード（スペースで区切ると複数条件指定可能）
" & vbCRLF Response.Write "
" & vbCRLF Response.Write "■検索条件
" & vbCRLF Response.Write "AND OR " & vbCRLF Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "
" If Wki_word <> "" Then ' 検索の実行と結果表示 Wki_word = Replace(Wki_word,"　"," ") Wki_word = Replace(Wki_word,vbTab," ") pairs_array = split(Wki_word," ") read_data() Wk_Ix = 0 For Each Wkl_Log In Wk_AllLog_array Wk_flag = 0 Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 7 Then Wk_no = Wkl_Log_array(0) Wk_reno = Wkl_Log_array(1) Wk_date = Wkl_Log_array(2) Wk_name = Wkl_Log_array(3) Wk_mail = Wkl_Log_array(4) Wk_sub = Wkl_Log_array(5) Wk_mes = Wkl_Log_array(6) Wk_url = Wkl_Log_array(7) Else Wk_no = "" Wk_reno = "" Wk_date = "" Wk_name = "" Wk_mail = "" Wk_sub = "" Wk_mes = "" Wk_url = "" End If For Each Wk_pair In pairs_array If (Instr(Wk_mes,Wk_pair) > 0) OR (Instr(Wk_sub,Wk_pair) > 0) OR (Instr(Wk_name,Wk_pair) > 0) Then Wk_flag = 1 If Wki_cond = "or" Then Exit For End If Else If Wki_cond = "and" Then Wk_flag = 0 Exit For End If End If Next If Wk_flag <> 0 Then Wk_Ix = Wk_Ix + 1 Wkf_AllLog_array(Wk_Ix - 1) = Wkl_Log ' 結果を退避 End If Next '------------------------------------------------------------------------------------------------------------------ Response.Write "" Response.Write "" Response.Write "

" Response.Write Wk_Ix & " 件のデータが有ります" & "
" Response.Write "

" & vbCRLF ' 改ページ用処理 Wk_start = CInt(Wk_TopCnt) + 1 Wk_end = CInt(Wk_TopCnt) + CInt(Wk_p_log) Wk_Ix = 0 For Each Wkf_AllLog In Wkf_AllLog_array Wk_Ix = Wk_Ix + 1 If (Wk_Ix < Wk_start) or (Wk_Ix > Wk_end) Then Wkf_Log_array = split(Wkf_AllLog,"<>") If UBound(Wkf_Log_array) < 9 Then Wk_Ix = Wk_Ix - 1 Exit For End If Else Wkf_Log_array = split(Wkf_AllLog,"<>") If UBound(Wkf_Log_array) >= 10 Then Wk_no = Wkf_Log_array(0) Wk_reno = Wkf_Log_array(1) Wk_date = Wkf_Log_array(2) Wk_name = Wkf_Log_array(3) Wk_mail = Wkf_Log_array(4) Wk_sub = Wkf_Log_array(5) Wk_mes = Wkf_Log_array(6) Wk_url = Wkf_Log_array(7) Wk_host = Wkf_Log_array(8) Wk_pwd = Wkf_Log_array(9) Wk_User_Agent = Wkf_Log_array(10) Else Exit For End If Call DetailsView2() ' 明細表示 End If Next Wk_Next_top = CInt(Wk_TopCnt) + Wk_p_log Wk_back_top = CInt(Wk_TopCnt) - Wk_p_log If ((Wk_back_top >= 0) or (Wk_Next_top < Wk_ix)) Then Response.Write "

" & vbCRLF End If Response.Write "" Response.Write "" Response.Write "" Response.Write "

" Response.Write "" If Wk_back_top >= 0 Then Response.Write "" End If If Wk_Next_top < Wk_Ix Then Response.Write "" End If Response.Write "

" Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF '------------------------------------------------------------------------------------------------------------------ Else Response.Write "" Response.Write "" Response.Write "

" Response.Write "キーワードを入力して下さい。" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF End If Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' 管理モード '*-----------------------------------------------------------------------------* Sub admin() If (Wki_pass <> Wk_pass) AND (Wki_pass <> "") Then Call error("パスワードが違います") End If Call header Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "★管理者用ページ★" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF If Request.Form("pass") = "" Then Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Response.Write "■パスワード（必須）
" & vbCRLF Response.Write "
" Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Else If Request.Form("del") <> "" Then ' チェックがある時　その項目を削除 For Each Wkl_del In Request.Form("del") Call read_data() Call delete_data(Wkl_del) Next End If If Request.Form("admesmode") = "on" Then ' 管理者からのメッセージ処理 read_data() Wki_admes = Request.Form("admes") write_data2(Wki_admes) End If read_data() Wkl_admes = Replace(Wk_admes,"&","&") Wkl_admes = Replace(Wkl_admes,"<","<") Wkl_admes = Replace(Wkl_admes,">",">") Wkl_admes = Replace(Wkl_admes,"
",vbcr) ' メッセージ編集画面を表示 Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF ' 削除画面を表示 Response.Write "

" & vbCRLF Response.Write "" Response.Write "" Response.Write "

" Response.Write "

" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF ' read_data() For Each Wkl_Log In Wk_AllLog_array Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 10 Then Wk_no = Wkl_Log_array(0) Wk_reno = Wkl_Log_array(1) Wk_date = Wkl_Log_array(2) Wk_name = Wkl_Log_array(3) Wk_mail = Wkl_Log_array(4) Wk_sub = Wkl_Log_array(5) Wk_mes = Wkl_Log_array(6) Wk_url = Wkl_Log_array(7) Wk_host = Wkl_Log_array(8) Wk_pwd = Wkl_Log_array(9) Wk_User_Agent = Wkl_Log_array(10) Else Exit For End If If Wk_mail <> "" Then Wk_name="" & Wk_name & "" End If Wk_mes = Replace(Wk_mes,"
","") Wk_mes = Replace(Wk_mes,"<","<") Wk_mes = Replace(Wk_mes,">",">") If (len(Wk_mes) > 23) Then Wk_mes = left(Wk_mes,20) Wk_mes = Wk_mes & "･･･" End If Response.Write "" & Wk_no & " [" & Wk_sub & "] " & Wk_name & " " & Wk_mes & "
" & vbCRLF Next Response.Write "
" & vbCRLF Response.Write "" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" & vbCRLF End If Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' 削除 '*-----------------------------------------------------------------------------* Sub userdel() If (Wki_no = "") OR (Wki_pwd = "") Then Call error("削除Noまたは削除キーが未入力です") End If read_data() Wk_flag=0 For Each Wkl_Log In Wk_AllLog_array Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 10 Then Wk_no = Wkl_Log_array(0) Wk_reno = Wkl_Log_array(1) Wk_date = Wkl_Log_array(2) Wk_name = Wkl_Log_array(3) Wk_mail = Wkl_Log_array(4) Wk_sub = Wkl_Log_array(5) Wk_mes = Wkl_Log_array(6) Wk_url = Wkl_Log_array(7) Wk_host = Wkl_Log_array(8) Wk_pwd = Wkl_Log_array(9) Wk_User_Agent = Wkl_Log_array(10) End If If Wki_no = Wk_no Then Wk_flag = 1 Exit For End If Next If Wk_flag = 0 Then Call error("既に削除済です") End If If Wk_pwd = "" Then Call error("削除キー未設定") End If If Wk_pwd <> Wki_pwd Then Call error("削除キー間違い") End If ' delete_data(Wk_no) ' 削除処理 End Sub ' '*-----------------------------------------------------------------------------* ' デコード処理 '*-----------------------------------------------------------------------------* Sub decode() Dim week_array(6) week_array(0) = "日" week_array(1) = "月" week_array(2) = "火" week_array(3) = "水" week_array(4) = "木" week_array(5) = "金" week_array(6) = "土" ' If (Request.ServerVariables("REQUEST_METHOD") = "POST") Then If (Request.ServerVariables("CONTENT_LENGTH") > 38400) Then Call error("内容が長いので
短くして下さい") End If End If ' Wk_User_Agent = Request.ServerVariables("HTTP_USER_AGENT") ' Wki_name = Request.Form("name") Wki_name = Replace(Wki_name,vbcr,"") Wki_name = Replace(Wki_name,vblf,"") Wki_name = Replace(Wki_name,"<","<") Wki_name = Replace(Wki_name,">",">") ' Wki_sub = Request.Form("sub") Wki_sub = Replace(Wki_sub,vbcr,"") Wki_sub = Replace(Wki_sub,vblf,"") Wki_sub = Replace(Wki_sub,"<","<") Wki_sub = Replace(Wki_sub,">",">") If Wki_sub = "" Then Wki_sub = "無題" End If ' Wki_mes = Request.Form("mes") If (Wk_tagkey = 0) Then ' タグ処理 Wki_mes = Replace(Wki_mes,"&","&") Wki_mes = Replace(Wki_mes,"<","<") Wki_mes = Replace(Wki_mes,">",">") Else Wki_mes = Replace(Wki_mes,"<>","<>") If InStr(Wki_mes,"") > 0 Then For Wk_Ix = 1 to YLenB(Wki_mes) If (Wk_Ix => InStr(Wki_mes,"")+2) >= Wk_Ix) Then '読み飛ばす Else Wkl_value = Wkl_value & Mid(Wki_mes,Wk_Ix,1) End If Next Wki_mes = Wkl_value End If End If End If Wki_mes = Replace(Wki_mes,vbcrlf,"
") Wki_mes = Replace(Wki_mes,vbcr,"
") Wki_mes = Replace(Wki_mes,vblf,"
") ' Wki_email = Request.Form("email") Wki_email = Replace(Wki_email,vbcr,"") Wki_email = Replace(Wki_email,vblf,"") ' Wki_url = Request.Form("url") Wki_url = Replace(Wki_url,vbcr,"") Wki_url = Replace(Wki_url,vblf,"") If left(Wki_url,7) <> "http://" Then Wki_url = "" End If If Request.Querystring("mode") = "" Then Wk_mode = Request.Form("mode") Else Wk_mode = Request.Querystring("mode") End If Wki_pwd = Cstr(Request.Form("pwd")) Wki_pwd = Replace(Wki_pwd,vbcr,"") Wki_pwd = Replace(Wki_pwd,vblf,"") Wki_pwd2 = Wki_pwd ' クッキー用 '*--- 暗号化 Wki_pwd = Cstr(CryptPwd(Wki_pwd)) Wk_TopCnt = CInt(Request.Querystring("TopCnt")) ' 日時の取得及び編集 If Len(cstr(Hour(GetdateString))) = 2 Then Wk_hour = cstr(Hour(GetdateString)) Else Wk_hour = "0" & cstr(Hour(GetdateString)) End If If Len(cstr(Minute(GetdateString))) = 2 Then Wk_min = cstr(Minute(GetdateString)) Else Wk_min = "0" & cstr(Minute(GetdateString)) End If If Len(cstr(Second(GetdateString))) = 2 Then Wk_sec = cstr(Second(GetdateString)) Else Wk_sec = "0" & cstr(Second(GetdateString)) End If Wk_year = cstr(Year(GetdateString)) ' Wk_year = Right(Wk_year,2) If Len(cstr(Month(GetdateString))) = 2 Then Wk_mon = cstr(Month(GetdateString)) Else Wk_mon = "0" & cstr(Month(GetdateString)) End If If Len(cstr(Day(GetdateString))) = 2 Then Wk_mday = cstr(Day(GetdateString)) Else Wk_mday = "0" & cstr(Day(GetdateString)) End If Wk_wday = (Weekday(GetdateString,vbSunday) - 1) '--- 日時の編集 Wk_date = Wk_year & "/" & Wk_mon & "/" & Wk_mday & "(" & week_array(Wk_wday) & ") " & Wk_hour & ":" & Wk_min '--- If (Request.Form("word") <> "") Then Wki_word = Request.Form("word") Else Wki_word = Request.Querystring("word") End If '--- If (Request.Form("cond") <> "") Then Wki_cond = Request.Form("cond") Else Wki_cond = Request.Querystring("cond") End If '--- If (Request.Form("no") <> "") Then Wki_no = Request.Form("no") Else Wki_no = Request.Querystring("no") End If '--- If (Request.Form("reno") <> "") Then Wki_reno = Request.Form("reno") Else Wki_reno = Request.Querystring("reno") End If '--- Wki_pass = Request.Form("pass") '--- Wki_res = Request.Querystring("res") End Sub ' '*-----------------------------------------------------------------------------* ' HTMLヘッダ '*-----------------------------------------------------------------------------* Sub header() Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & Wk_title & "" & vbCRLF Response.Write "" & vbCRLF Response.Write Wk_body & vbCRLF Response.Write "" Response.Write "" Response.Write "

" & vbCRLF Call Top_Banner() If Wk_ImgTitle <> "" Then Response.Write "" & vbCRLF Response.Write " " & Wk_title & "

" & vbCRLF Response.Write "" & vbCRLF Else Response.Write "" & vbCRLF Response.Write "" & Wk_title & "" Response.Write "" & vbCRLF End If Response.Write "

" & vbCRLF If Wk_acnt = 0 Then Response.Write "" & vbCRLF Response.Write "訪問者数 " & Cnt_All & vbCRLF Response.Write "昨日 " & Cnt_Yesterday & vbCRLF Response.Write "今日 " & Cnt_Today & "
" & vbCRLF Response.Write "" & vbCRLF End If Response.Write "

" & vbCRLF End Sub ' '*-----------------------------------------------------------------------------* ' 明細の表示 '*-----------------------------------------------------------------------------* Sub DetailsView() Wkl_mes_all = "" Wk_Ix = 0 ' If (Wk_reno = "") and (Wk_flg = 1) Then Response.Write "" & vbCRLF Response.Write "
" & vbCRLF Wk_flg = 1 End If ' If Wk_autolink = 1 Then ' 自動リンク If Instr(Wk_mes,"
") > 0 Then Wk_mes_array = Split(Wk_mes,"
") For Each Wkl_mes In Wk_mes_array If Wk_Ix > 0 Then Wkl_mes_all = Wkl_mes_all & "
" & auto_link(Wkl_mes) Else Wkl_mes_all = auto_link(Wkl_mes) End If Wk_Ix = Wk_Ix + 1 Next Wk_mes = Wkl_mes_all Else Wk_mes = auto_link(Wk_mes) End If End If If Wk_autobr = 1 Then ' 自動改行 Wk_mes = Replace(Wk_mes,"。
","。") Wk_mes = Replace(Wk_mes,"！
","！") Wk_mes = Replace(Wk_mes,"？
","？") Wk_mes = Replace(Wk_mes,"。","。
") Wk_mes = Replace(Wk_mes,"！","！
") Wk_mes = Replace(Wk_mes,"？","？
") Wk_mes = Replace(Wk_mes,"
。","。") Wk_mes = Replace(Wk_mes,"
！","！") Wk_mes = Replace(Wk_mes,"
？","？") End If ' If Wk_mail <> "" Then Wk_name = "" & Wk_name & "" End If If Wk_url <> "" Then Wk_url = "の <" & "ホームページ" & "> " End If If Wk_reno = "" Then Response.Write "" Response.Write "" Response.Write "

" Response.Write "" Response.Write "

" Wkl_mes = Replace(Wk_mes & "
","

","
") Response.Write "" Response.Write Wkl_mes & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Wk_flg = 1 Else Response.Write "

" Response.Write "
" & vbCRLF Response.Write "" Response.Write "[" & Wk_no & "] " & vbCRLF Response.Write "" & Wk_sub & "" & vbCRLF Response.Write " 投稿者：" & Wk_name & "さん " & Wk_url & Wk_date & "
" & vbCRLF Response.Write "" ' If Wk_Agent = 0 Then Response.Write "" Response.Write Wk_User_Agent & vbCRLF Response.Write "" End If Response.Write "
" Wkl_mes = Replace(Wk_mes & "
","

","
") Response.Write "" Response.Write Wkl_mes & vbCRLF Response.Write "" Response.Write "
" & vbCRLF Response.Write "

" & vbCRLF Wk_flg = 1 End If End Sub ' '*-----------------------------------------------------------------------------* ' 明細の表示 '*-----------------------------------------------------------------------------* Sub DetailsView2() Wkl_mes_all = "" Wk_Ix = 0 ' If Wk_autolink = 1 Then ' 自動リンク If Instr(Wk_mes,"
") > 0 Then Wk_mes_array = Split(Wk_mes,"
") For Each Wkl_mes In Wk_mes_array If Wk_Ix > 0 Then Wkl_mes_all = Wkl_mes_all & "
" & auto_link(Wkl_mes) Else Wkl_mes_all = auto_link(Wkl_mes) End If Wk_Ix = Wk_Ix + 1 Next Wk_mes = Wkl_mes_all Else Wk_mes = auto_link(Wk_mes) End If End If If Wk_autobr = 1 Then ' 自動改行 Wk_mes = Replace(Wk_mes,"。
","。") Wk_mes = Replace(Wk_mes,"！
","！") Wk_mes = Replace(Wk_mes,"？
","？") Wk_mes = Replace(Wk_mes,"。","。
") Wk_mes = Replace(Wk_mes,"！","！
") Wk_mes = Replace(Wk_mes,"？","？
") Wk_mes = Replace(Wk_mes,"
。","。") Wk_mes = Replace(Wk_mes,"
！","！") Wk_mes = Replace(Wk_mes,"
？","？") End If ' If Wk_mail <> "" Then Wk_name = "" & Wk_name & "" End If If Wk_url <> "" Then Wk_url = "の <" & "ホームページ" & "> " End If Response.Write "" Response.Write "" Response.Write "

" If Wk_reno = "" Then Response.Write "" Response.Write "

" Wkl_mes = Replace(Wk_mes & "
","

","
") Response.Write "" Response.Write Wkl_mes & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Else Response.Write "" Response.Write "[" & Wk_no & "] " & vbCRLF Response.Write "[親記事へ] " & vbCRLF Response.Write "" & Wk_sub & "" & vbCRLF Response.Write " 投稿者：" & Wk_name & "さん " & Wk_url & Wk_date & "
" & vbCRLF Response.Write "" ' If Wk_Agent = 0 Then Response.Write "" Response.Write Wk_User_Agent & vbCRLF Response.Write "" End If Response.Write "

" Wkl_mes = Replace(Wk_mes & "
","

","
") Response.Write "" Response.Write Wkl_mes & vbCRLF Response.Write "" Response.Write "

" & vbCRLF End If Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF End Sub ' '*-----------------------------------------------------------------------------* ' エラー処理 '*-----------------------------------------------------------------------------* Sub error(Wk_In) Call header Response.Write "" Response.Write "" Response.Write "

" Response.Write "" ' Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "[掲示板に戻る]
" & vbCRLF Response.Write "" Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "ERROR !!

" & Wk_In & "" & vbCRLF Call footer() Response.End End Sub ' '*-----------------------------------------------------------------------------* ' ホストアドレス取得 '*-----------------------------------------------------------------------------* Sub get_host() Wk_host = Request.ServerVariables("REMOTE_HOST") Wk_addr = Request.ServerVariables("REMOTE_ADDR") If Wk_host = "" Then Wk_host = Wk_addr End If End Sub ' '*-----------------------------------------------------------------------------* ' メール送信 '*-----------------------------------------------------------------------------* Sub send_mail() Wk_m_mes = Wki_mes Wk_m_mes = Replace(Wk_m_mes,"
",vblf) Wk_m_mes = Replace(Wk_m_mes,"<","<") Wk_m_mes = Replace(Wk_m_mes,">",">") Wk_m_mes = Replace(Wk_m_mes,"&","&") ' Set ml = Server.CreateObject("basp21") ' Basp21を利用したメール送信 smtpsrv = Wk_smtpsrv ' SMTPサーバーの指定 mailto = Wk_mailto & Chr(9) & ">Content-Type: text/plain; charset=x-sjis" ' 受信者のメールアドレス ' If Wki_email = "" Then ' メールの送信者名＆アドレス mailfrom = Wk_name & "<" & "aspibbs@nomail.xxx" & ">" Else mailfrom = Wk_name & "<" & Wki_email & ">" End If ' sbj = Wk_title & " > " & Wki_sub ' メールの題名(Subject) ' メールの内容(Body) body = "======================================================================" & vbCrLf body = body & "書き込み日時：" & Wk_date & vbCrLf body = body & "投稿ホスト　：" & Wk_host & vbCrLf body = body & "投稿者名　　：" & Wki_name & vbCrLf body = body & "投稿者メール：" & Wki_email & vbCrLf body = body & "投稿者ＨＰ　：" & Wki_url & vbCrLf body = body & "題名　　　　：" & Wki_sub & vbCrLf body = body & "▼内容" & vbCrLf body = body & Wk_m_mes & vbCrLf body = body & "======================================================================" & vbCrLf ' file="" ' 添付ファイルの指定 ' rc = ml.SendMail(smtpsrv,mailto,mailfrom,sbj,body,file) ' メールの送信 Set ml = Nothing If rc <> "" Then ' メールの送信失敗後のメッセージ出力 Call error("メール送信に失敗しました") End If End Sub ' '*-----------------------------------------------------------------------------* ' 自動リンク (タグがない時のみ) ' この自動リンクロジックはＷＩＮＧ☆さん　に　著作権が有ります ' URL : http://www04.u-page.so-net.ne.jp/yd5/wing/aspyui/ ' E-mail : wing@yd5.so-net.ne.jp '*-----------------------------------------------------------------------------* Function auto_link(Wk_In) If (Instr(1,Wk_In,"http://") > 0 or Instr(1,Wk_In,"ftp://") > 0 or Instr(1,Wk_In,"mailto:") > 0) and InStr(1,Wk_In,"<") = 0 Then Wk_In = Replace(Wk_In,"__URL__","") flg = 0 Wk_Incp = "" urlcp = "" for i = 1 to len(Wk_In) j = Mid(Wk_In,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(Wk_In,i,7) = "http://" or Mid(Wk_In,i,6) = "ftp://" or Mid(Wk_In,i,7) = "mailto:" Then If flg = 1 Then Wk_Incp = Replace(Wk_Incp,"__URL__",urlcp) Wk_Incp = Wk_Incp & "" urlcp = "" End If If Mid(Wk_In,i,7) = "mailto:" Then 'メールの場合のフォーマット設定 Wk_Incp = Wk_Incp & "" Else 'URL又はftpの場合のフォーマット設定 Wk_Incp = Wk_Incp & "" End If flg = 1 End If If flg = 1 Then urlcp = urlcp & Mid(Wk_In,i,1) End If Case Else If flg = 1 Then Wk_Incp = Replace(Wk_Incp,"__URL__",urlcp) Wk_Incp = Wk_Incp & "" flg = 0 urlcp = "" End If End Select Wk_Incp = Wk_Incp & j Next If flg = 1 Then Wk_Incp = Replace(Wk_Incp,"__URL__",urlcp) Wk_Incp = Wk_Incp & "" End If auto_link = Wk_Incp Else auto_link = Wk_In End If End Function ' '*-----------------------------------------------------------------------------* '* データの読み込み '*-----------------------------------------------------------------------------* sub read_data() On Error Resume Next Set objFile = Server.CreateObject("Scripting.FileSystemObject") Set DataFile = objFile.OpenTextFile(Server.MapPath(Wk_logfile), 1, FALSE) If Err.Number > 0 Then Call error("Read Error : " & Wk_logfile) Else Do Until DataFile.AtEndOfStream Wk_LineCnt = DataFile.Line - 1 If Wk_LineCnt > 0 Then Wk_AllLog_array(Wk_LineCnt - 1) = DataFile.ReadLine Else Wkl_Log = DataFile.ReadLine Wkl_Log_array = Split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 1 Then Wk_tno = Wkl_Log_array(0) Wk_admes = Wkl_Log_array(1) End If End If Loop End If ' DataFile.Close Set DataFile = Nothing Set objFile = Nothing ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* '* データの書き込み '*-----------------------------------------------------------------------------* Sub write_data(Wk_In) On Error Resume Next Call File_Lock() Set objFile = Server.CreateObject("Scripting.FileSystemObject") Set WDateFile = objFile.OpenTextFile(Server.MapPath(Wk_logfile), 2, TRUE) ' If Err.Number > 0 Then Call error("Write Error : " & Wk_logfile) Else Wkl_In_array = split(Wk_In,"<>") If UBound(Wkl_In_array) >= 1 Then Wkl_no = Wkl_In_array(0) Wkl_reno = Wkl_In_array(1) End If ' WDateFile.WriteLine(Wk_tno & "<>" & Wk_admes & "<><><><><><><><><><><><>") If Wkl_reno = "" Then ' 親記事の時 WDateFile.WriteLine(Wk_In) For Wk_Ix = 0 To (Wk_Max - 2) WDateFile.WriteLine(Wk_AllLog_array(Wk_Ix)) Next Else ' 子記事の時 If Wk_sort_flg = 0 Then ' ソートしない Wkl_sw = 0 Ix1 = 0 ReDim Preserve Wkl_AllLog_array2(Wk_Max - 1) For Each Wkl_Log In Wk_AllLog_array Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 1 Then Wkl_Log_no = Wkl_Log_array(0) Wkl_Log_reno = Wkl_Log_array(1) Else Exit For End If If (Wkl_sw = 0) and (Wkl_reno = Wkl_Log_no) Then Wkl_sw = 1 Else If (Wkl_sw = 1) and (Wkl_reno <> Wkl_Log_reno) Then Wkl_sw = 2 Wkl_AllLog_array2(Ix1) = Wk_In Ix1 = Ix1 + 1 End If End If Wkl_AllLog_array2(Ix1) = Wkl_Log Ix1 = Ix1 + 1 Next If Wkl_sw = 1 Then Wkl_AllLog_array2(Ix1) = Wk_In End If For Each Wkl_Log2 In Wkl_AllLog_array2 WDateFile.WriteLine(Wkl_Log2) Next Else ' 最上へのソートをする Wkl_sw = 0 Ix1 = 0 Iy1 = 0 ReDim Preserve Wkl_AllLog_array2(Wk_Max - 1) ReDim Preserve Wkl_AllLog_array3(Wk_Max - 1) For Each Wkl_Log In Wk_AllLog_array Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 1 Then Wkl_Log_no = Wkl_Log_array(0) Wkl_Log_reno = Wkl_Log_array(1) Else Exit For End If If Wkl_reno = Wkl_Log_no Then Wkl_AllLog_array2(Ix1) = Wkl_Log Ix1 = Ix1 + 1 Wkl_sw = 1 Else If Wkl_reno = Wkl_Log_reno Then Wkl_AllLog_array2(Ix1) = Wkl_Log Ix1 = Ix1 + 1 Else If (Wkl_sw = 1) And (Wkl_reno <> Wkl_Log_reno) Then Wkl_AllLog_array2(Ix1) = Wk_In Wkl_AllLog_array3(Iy1) = Wkl_Log Ix1 = Ix1 + 1 Iy1 = Iy1 + 1 Wkl_sw = 2 Else Wkl_AllLog_array3(Iy1) = Wkl_Log Iy1 = Iy1 + 1 End If End If End If Next If Wkl_sw = 1 Then Wkl_AllLog_array2(Ix1) = Wk_In Ix1 = Ix1 + 1 End If For Each Wkl_Log3 In Wkl_AllLog_array3 Wkl_AllLog_array2(Ix1) = Wkl_Log3 Ix1 = Ix1 + 1 Next For Each Wkl_Log2 In Wkl_AllLog_array2 WDateFile.WriteLine(Wkl_Log2) Next End If End If End If ' WDateFile.Close Set WDataFile = Nothing Set objFile = Nothing ' Call File_UnLock() ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* '* データの書き込み '*-----------------------------------------------------------------------------* Sub write_data2(In_Data) On Error Resume Next Call File_Lock() Set objFile = Server.CreateObject("Scripting.FileSystemObject") Set WDateFile = objFile.OpenTextFile(Server.MapPath(Wk_logfile), 2, TRUE) ' If Err.Number > 0 Then Call error("Write Error : " & Wk_logfile) Else In_Data = Replace(In_Data,"&","&") In_Data = Replace(In_Data,"<","<") In_Data = Replace(In_Data,">",">") In_Data = Replace(In_Data,vbcrlf,"
") In_Data = Replace(In_Data,vbcr,"
") In_Data = Replace(In_Data,vblf,"
") WDateFile.WriteLine(Wk_tno & "<>" & In_Data & "<><><><><><><><><><><><>") For Each Wkl_Log In Wk_AllLog_array WDateFile.WriteLine(Wkl_Log) Next End If ' WDateFile.Close Set WDataFile = Nothing Set objFile = Nothing ' Call File_UnLock() ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* '* データの削除 '*-----------------------------------------------------------------------------* Sub delete_data(Wk_In) On Error Resume Next Call File_Lock() Set objFile = Server.CreateObject("Scripting.FileSystemObject") Set WDateFile = objFile.OpenTextFile(Server.MapPath(Wk_logfile), 2, TRUE) ' If Err.Number > 0 Then Call error("Write Error : " & Wk_logfile) Else WDateFile.WriteLine(Wk_tno & "<>" & Wk_admes & "<><><><><><><><><><><><>") For Each Wkl_Log In Wk_AllLog_array Wkl_Log_array = split(Wkl_Log,"<>") If UBound(Wkl_Log_array) >= 10 Then Wkl_no = Wkl_Log_array(0) Wkl_reno = Wkl_Log_array(1) Wkl_date = Wkl_Log_array(2) Wkl_name = Wkl_Log_array(3) Wkl_mail = Wkl_Log_array(4) Wkl_sub = Wkl_Log_array(5) Wkl_mes = Wkl_Log_array(6) Wkl_url = Wkl_Log_array(7) Wkl_host = Wkl_Log_array(8) Wkl_pwd = Wkl_Log_array(9) Wkl_User_Agent = Wkl_Log_array(10) Else Wkl_no = "" Wkl_reno = "" Wkl_date = "" Wkl_name = "" Wkl_mail = "" Wkl_sub = "" Wkl_mes = "" Wkl_url = "" Wkl_host = "" Wkl_pwd = "" End If If Wkl_no = Wk_In Then Wkl_Log = Wkl_no & "<>" Wkl_Log = Wkl_Log & Wkl_reno & "<>" Wkl_Log = Wkl_Log & Wk_date & "<>" Wkl_Log = Wkl_Log & Wkl_name & "<>" Wkl_Log = Wkl_Log & Wkl_email & "<>" Wkl_Log = Wkl_Log & Wkl_sub & "<>" Wkl_Log = Wkl_Log & "削除されました" & "<>" Wkl_Log = Wkl_Log & Wkl_url & "<>" Wkl_Log = Wkl_Log & Wk_host & "<>" Wkl_Log = Wkl_Log & Wkl_pwd & "<>" Wkl_Log = Wkl_Log & Wk_User_Agent & "<>" Wkl_Log = Wkl_Log & "<><>" End If WDateFile.WriteLine(Wkl_Log) Next End If ' WDateFile.Close Set WDataFile = Nothing Set objFile = Nothing ' Call File_UnLock() ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* '* ファイルのロック '*-----------------------------------------------------------------------------* Sub File_Lock() On Error Resume Next Set objFile1 = Server.CreateObject("Scripting.FileSystemObject") If objFile1.FileExists(Server.MapPath(Wk_Lockfile)) = true Then Call error("他の方が書込み中
お手数ですが
再度実行して下さい。") Exit Sub End If ' Application.Lock ' Set objFile2 = Server.CreateObject("Scripting.FileSystemObject") set LockFile = objFile2.CreateTextFile(Server.MapPath(Wk_Lockfile),true,False) ' Set LockFile = Nothing Set objFile1 = Nothing Set objFile2 = Nothing ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* '* ファイルのロック解除 '*-----------------------------------------------------------------------------* Sub File_UnLock() On Error Resume Next ' Set objFile = Server.CreateObject("Scripting.FileSystemObject") set UnLockFile = objFile.DeleteFile(Server.MapPath(Wk_Lockfile),true) ' Set UnLockFile = Nothing Set objFile = Nothing ' Application.Unlock ' On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* ' フッター '*-----------------------------------------------------------------------------* Sub footer() Response.Write "" Response.Write "" Response.Write "

" Call Bottom_Banner() Response.Write "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF Response.Write "

" & vbCRLF Response.Write "

" & Wk_ver & "

" & vbCRLF Response.Write "

" & vbCRLF Response.Write "" & vbCRLF Response.Write "" & vbCRLF End Sub ' '*--- アクセスカウント処理 ----------------------------------------------------* ' アクセスカウント　を　行う '*-----------------------------------------------------------------------------* Sub AccessCount() Dim Wkl_Date On Error Resume Next ' Set objFile1 = Server.CreateObject("Scripting.FileSystemObject") If (objFile1.FileExists(Server.MapPath(Wk_LockAfile)) = true) or (Instr(Request.ServerVariables("HTTP_REFERER"),Wk_script) > 0) Then 'カウント中に別の人がきた場合カウントしない（出来ない） Set objFile = Server.CreateObject("Scripting.FileSystemObject") SMPACountFile = Server.MapPath("acount.dat") ' Set ACountFile = objFile.OpenTextFile(SMPACountFile, 1, FALSE) If Err.Number > 0 Then ' 初回とエラーの時は新規処理 Cnt_All = 0 OldDate = Wkl_Date Cnt_Today = 0 Cnt_Yesterday = 0 Else Wk_ReadData = ACountFile.ReadLine ' カウントファイルの読み込み Wk_Data = Split(Wk_ReadData,"<>") OldDate = Wk_Data(0) Cnt_All = CLng(Wk_Data(1)) Cnt_Today = CLng(Wk_Data(2)) Cnt_Yesterday = CLng(Wk_Data(3)) End If ' Exit Sub End If ' Wkl_Date = Cstr(DateValue(GetdateString())) Set objFile = Server.CreateObject("Scripting.FileSystemObject") SMPACountFile = Server.MapPath("acount.dat") ' Set ACountFile = objFile.OpenTextFile(SMPACountFile, 1, FALSE) If Err.Number > 0 Then ' 初回とエラーの時は新規処理 Cnt_All = 0 OldDate = Wkl_Date Cnt_Today = 0 Cnt_Yesterday = 0 Else Wk_ReadData = ACountFile.ReadLine ' カウントファイルの読み込み Wk_Data = Split(Wk_ReadData,"<>") OldDate = Wk_Data(0) Cnt_All = CLng(Wk_Data(1)) Cnt_Today = CLng(Wk_Data(2)) Cnt_Yesterday = CLng(Wk_Data(3)) End If ' If OldDate <> Wkl_Date Then '日付が変わった時 OldDate = Wkl_Date Cnt_Yesterday = Cnt_Today Cnt_Today = 0 End If ' Cnt_All = Cnt_All + 1 Cnt_Today = Cnt_Today + 1 ' ACountFile.Close '--- ファイルのロック Application.Lock ' Set objFile2 = Server.CreateObject("Scripting.FileSystemObject") set LockFile = objFile2.CreateTextFile(Server.MapPath(Wk_LockAfile),true,False) ' Set LockFile = Nothing Set objFile1 = Nothing Set objFile2 = Nothing '--- ファイルのロック　ここまで '*--- カウントファイルへ書き込み Set ACountWFile = objFile.OpenTextFile(SMPACountFile, 2, TRUE) ACountWFile.WriteLine OldDate & "<>" & Cnt_All & "<>" & Cnt_Today & "<>" & Cnt_Yesterday ACountWFile.Close ' '--- ロック解除 Set objFile = Server.CreateObject("Scripting.FileSystemObject") set UnLockFile = objFile.DeleteFile(Server.MapPath(Wk_LockAfile),true) ' Set UnLockFile = Nothing Set objFile = Nothing ' Application.Unlock '--- ロック解除　ここまで On Error GoTo 0 End Sub ' '*-----------------------------------------------------------------------------* ' '*-----------------------------------------------------------------------------* Function YLenB(ByVal InData) Dim Wk_Count Dim Ix1 Wk_Count = 0 For Ix1 = 1 To Len(InData) If (Asc(Mid(InData, Ix1, 1)) And &HFF00) = 0 Then Wk_Count = Wk_Count + 1 Else Wk_Count = Wk_Count + 2 End If Next YLenB = Wk_Count End Function ' '*-----------------------------------------------------------------------------* ' 一応暗号化？　って　言っていいのかな？ '*-----------------------------------------------------------------------------* Function CryptPwd(In_Data) Wk_CryptPwd = "" For Ix1 = 1 to Len(In_Data) Wk_CryptPwd = Wk_CryptPwd & Not(Asc(Mid(CStr(In_Data),Ix1,1))) Next CryptPwd = Wk_CryptPwd End Function ' '*-----------------------------------------------------------------------------* ' '*-----------------------------------------------------------------------------* Function GetdateString() GetdateString = dateadd("h",+9,CStr(GetJstString())) End Function ' '*--- メールアドレスチェック処理 ----------------------------------------------* ' メールアドレスのチェックを行う '*-----------------------------------------------------------------------------* Function MailCheck(Wk_Mail) Dim Ix1 Dim Wk_Array '--- @が一文字目以外に存在するかチェック（一文字目に@か.はエラー） If (Left(Wk_Mail,1) = "@") or (Left(Wk_Mail,1) = ".") Then MailCheck = "ERR" Else If (Right(Wk_Mail,1) = "@") or (Right(Wk_Mail,1) = ".") Then '@か.が一番最後に存在する場合はエラー MailCheck = "ERR" Else Wk_Array = Split(Wk_Mail,"@") '@が複数存在する場合はエラー If (UBound(Wk_Array) > 2) OR (UBound(Wk_Array) < 1) Then MailCheck = "ERR" Else If InStr(Wk_Array(1),".") < 1 Then '@以降に.が存在しない場合はエラー MailCheck = "ERR" End If End If End If End If End Function ' '*-----------------------------------------------------------------------------* ' '*-----------------------------------------------------------------------------* %>