'2ch/bbspinkの過去ログ倉庫のsubject.txtを連結収集するスクリプト（非連結版）

'
'2ch/bbspinkの掲示板の過去ログ倉庫にアクセスし、
'分散しているsubject.txtを連結してローカル保存するスクリプトです。
'
'[使い方]
'***必ず新しいフォルダを作って、2chsubjectget.vbsをそこに移動してから***、
'2chsubject.vbsを実行します。あとはダイアログの指示に従ってください。
'[必要環境]
'Windows Script5.5+IE5.0以上もしくはIE5.5がインストールされているWin98/Me/2000
'
'
'[更新履歴]
'2006/10/01 ver 1.00 作成
'2007/01/23 ver 1.00 公開
'                    
Const MsgBoxTitle = "ログ倉庫収集ツール for ２chdat"
Const FindTextFile = "Find.txt"
Const ForReading =1
Const ForWriting =2 
Const ForAppending =8 
Dim strFindText
Dim objOutPutFile

Dim iMode
Dim sRoot,sMBXFile,sMBXOldFile,sEMLExt,sSplitChr,sEMLDir
Dim Fs,regEx,tsMBX
Dim sBBS,sErr
Dim iLists,iCurList,iCurNumber,iOldList,iOldNumber
Dim sScriptTitle

Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True

sRoot=Fs.BuildPath(Fs.GetParentFolderName(WScript.ScriptFullName),"\") 'スクリプトのあるフォルダ

Set objOutPutFile = Fs.OpenTextFile(FindTextFile, ForReading,True)
if objOutPutFile.AtEndOfLine = False Then
	strFindText = objOutPutFile.ReadLine
End If


'//////変更可能項目//////
iMode=0 '0=mbx形式(全記事1ファイル,ピリオド区切り) 1=eml形式(一記事一ファイル)
sMBXFile=sRoot & "WSHLabBBS.txt" 'mbx形式のファイル名を指定します。
sMBXOldFile=sRoot & "WSHLabBBS.old" 'mbx形式のバックアップファイル名を指定します。
sSplitChr="." 'mbx形式ファイルのスプリット文字を指定。デフォルトは"."(ピリオド)
sEMLDir=sRoot & "emlfiles\" 'eml形式ファイルの保存フォルダ名。
sEMLExt=".eml" 'eml形式のファイルの拡張子を指定します。
'sBBS="http://www.roy.hi-ho.ne.jp/mutaguchi/bbs/" '掲示板のアドレス
sScriptTitle="WSHLab.掲示板" 'メッセージタイトル
'//////変更可能項目ここまで//////

'//URL入力//
strFindText = InputBox("検索する2ch/bbspinkの板アドレスを入力して下さい。" & vbCrLf & vbCrLf & _
						"(例　http://academy4.2ch.net/taiwan/)" & vbCrLf & vbCrLf & _
						"入力が無い場合は検索をしないで終了します。" ,MsgBoxTitle,strFindText)
If strFindText = "" Then
	WScript.Quit
End If

'////////入力されたURLを書き込み保存////////////
Set objOutPutFile = Fs.OpenTextFile(FindTextFile, ForWriting,True)
objOutPutFile.WriteLine strFindText


'sTempMsg="今からWSHLab.掲示板にアクセスし、記事を取得します。この作業には数分の時間を要します。" & vbCrLf
'If iMode=0 Then
'	iMsg=MsgBox (sTempMsg & "また、既存の" & Fs.GetFileName(sMBXFile) & "は上書きされます。" & vbCrLf & _
'	"開始してもよろしいでしょうか?",vbYesNo+vbQuestion,sScriptTitle)
'Else
'	iMsg=MsgBox (sTempMsg & "また、既存の" & sEMLDir & "*" & sEmlExt & "は上書きされます。" & vbCrLf & _
'	"開始してもよろしいでしょうか?",vbYesNo+vbQuestion,sScriptTitle)	
'End If
'If iMsg=vbNo Then ScriptQuit "ダウンロードをキャンセルしました。"


'////////////板の過去ログ倉庫のindexと元subjectをローカル保存////////////////
Fs.CreateTextFile "subject.txt"
'Fs.CreateTextFile "subject1.txt"
sIndexDoc=GetHTMLDocument(strFindText & "/kako/index.html",sRoot & "work_index.html")
sIndexDoc1=GetHTMLDocument(strFindText & "/kako/subject.txt",sRoot & "mokuji_subject.txt")
If sIndexDoc="" Then  'アクティブなリストが取得できない場合は終了
	sTempMsg="記事取得時に次のエラーが発生しました。" & vbCrLf & sErr & vbCrLf & _
	"アクティブなリストが取得できませんでした。"
	MsgBox sTempMsg,vbExclamation,sScriptTitle
	ScriptQuit sTempMsg
End If


'//////////////////元subject.txtの分析///////////////////
Dim urlList()
ReDim urlList(0)
	If Fs.FileExists("mokuji_subject.txt") Then readfile "mokuji_subject.txt"
If UBound(urlList)=0 Then
	MsgBox "倉庫リストのリンクURLが見つかりません"
	wscript.quit
Else
	Redim Preserve urlList(UBound(urlList)-1)
End If

i=0

'/////////////////ループ処理/////////////////////////
For Each url In urlList

Set re = New RegExp 
re.Pattern="(o\d+)<>.+" 
out= re.Replace(url, strFindText & "/kako/$1/subject.txt") 
'MsgBox out & "を、subject_work" & i & ".txtで保存します"
moto="subject.txt"
tuika="subject"&i&".txt"

work=GetHTMLDocument(out,tuika)

'////////
'http://www.jfast.net/~saikawa/wsh/text.html#copy
Set fs = WScript.CreateObject("Scripting.FileSystemObject")
'Set kai = fs.OpenTextFile("return.txt")
'kaiStr = kai.ReadAll
Set su = fs.OpenTextFile(tuika)
suStr = su.ReadAll

''Set te = fs.OpenTextFile(moto, 8, False) '8=ForAppending, False=noCreate
'te.Write vbNewLine  'vbCrLf
'te.Write kaiStr
'te.WriteLine
'te.Write suStr

'te.Close
su.Close
'kai.Close
'/////////

'MsgBox out 

'MsgBox url
'url1 = "http://www.geocities.jp/mirrorhenkan/mirrorhokan.html?u=" + url
'	Ie.Navigate url1 '指定したページを読み込む
'	Do 'ロードが完了するまで待つ
'		WScript.Sleep 100
'	Loop while complete=False
'	complete=False
'	For I=timeout To 1 Step -1 'カウントダウン!
'		IE.StatusText=I 
'		Do 
'			WScript.Sleep 1000 '1秒待つ
'		Loop Until IE.StatusBar=True 
'	Next
i=i+1
'////削除しないようコメントアウト////
'fs.DeleteFile tuika
Next
'/////////////////ループ処理終了/////////////////////////


'/////////////////空行削除ループ開始/////////////////////
'Dim seikeiList()
'ReDim seikeiList(0)
'
'If Fs.FileExists("subject1.txt") Then readfile "subject1.txt"
''	MsgBox "倉庫リストのリンクURLが見つかりません"
''If UBound(seikeiList)=0 Then
''	wscript.quit
''Else
'	Redim Preserve seikeiList(UBound(seikeiList)-1)
''End If
'
'Set seikei_te = fs.OpenTextFile("subject.txt", 8, False) '8=ForAppending, False=noCreate
'
'For Each seikei_line In seikeiList
''If url = !"" Then te.Write url
'seikei_te.Write seikei_line
'Next
'/////////////////空行削除ループ終了/////////////////////




'IE.StatusText="とりあえず自動巡回を終了しました。"

regEx.Pattern="o\d+<>"
iLists=regEx.Execute(sIndexDoc1).Count '過去記事の数(行数）
fs.DeleteFile "work_index.html"
fs.DeleteFile "mokuji_subject.txt"
MsgBox (strFindText & "/kako/内にある" & iLists &"個の倉庫からsubject.txtを作成しました")
'Dim iti
'iti=UBound(sIndexDoc1(1))
'MsgBox(iti)
'iCurList=iLists+1 '現在のアクティブなリストファイル
regEx.Pattern="<\!-- (\d+) -->"
iCurNumber=regEx.Execute(sIndexDoc).Count '最新の記事番号


'regEx.Pattern="<A HREF=""list\d+\.shtml"">"
'iLists=regEx.Execute(sIndexDoc).Count '過去記事の数
'iCurList=iLists+1 '現在のアクティブなリストファイル
'regEx.Pattern="<\!-- (\d+) -->"
'iCurNumber=regEx.Execute(sIndexDoc).Count '最新の記事番号

'If iMode=0 Then 'mbxファイル形式で保存する場合
'	If Fs.FileExists(sMBXFile) Then 'バックアップ
'		Fs.CopyFile sMBXFile,sMBXOldFile,True
'	End If
'	Set tsMBX=Fs.CreateTextFile(sMBXFile,True)
'Else
'	If Not Fs.FolderExists(sEMLDir) Then Fs.CreateFolder(sEMLDir)
'End If

'If Fs.FileExists(sRoot & "wshbbs.ini") Then
'	Set tsINI=Fs.OpenTextFile(sRoot & "wshbbs.ini",1)
'	aNum=Split(tsINI.ReadAll,"-",-1,1)
'	iOldList=CInt(aNum(0))
'	iOldNumber=CInt(aNum(1))
'	tsINI.Close
'Else
'	iOldList=1
'	iOldNumber=0
'End If

If iOldList=iCurList And iOldNumber=iCurNumber Then
	sTempMsg="新着記事はありませんでした。"
'	MsgBox sTempMsg,vbInformation,sScriptTitle
	ScriptQuit sTempMsg
End If

If iOldList < iCurList Then '新着過去記事があれば
	For I=iOldList To iLists
		If Fs.FileExists(sRoot & "list" & I & ".htm")=False And Fs.FileExists(sRoot & "list" & I & ".shtml")=False Then
		'もし過去記事ファイルがなければダウンロードしてくる。
			sDoc = GetHTMLDocument(sBBS & "list" & I & ".shtml",sRoot & "list" & I & ".htm")
		ElseIf Fs.FileExists(sRoot & "list" & I & ".htm")  Then
			sDoc = Fs.OpenTextFile(sRoot & "list" & I & ".htm",1).ReadAll
		ElseIf Fs.FileExists(sRoot & "list" & I & ".shtml") Then
			sDoc = Fs.OpenTextFile(sRoot & "list" & I & ".shtml",1).ReadAll
		End If

		If sDoc<>"" Then
			Call MakeMsgFile(sDoc,I)
		End If
	Next
End If

Call MakeMsgFile(sIndexDoc,iCurList)

If iMode=0 Then tsMBX.Close


Set tsINI=Fs.CreateTextFile(sRoot & "wshbbs.ini",True)
tsINI.Write iCurList & "-" & iCurNumber
tsINI.Close

sTempMsg=""
If sErr<>"" Then sTempMsg= "記事取得時のエラーは次のとおり:" & vbCrLf & sErr & vbCrLf

sTempMsg=sTempMsg & "記事取得およびデータ変換が終了しました。"
If iMode=0 Then 
	sTempMsg=sTempMsg & "生成した" & Fs.GetFileName(sMBXFile) & "をインポートしてください。" 
Else
	sTempMsg=sTempMsg & "生成した" & sEMLDir & "*" & sEmlExt & "をインポートしてください。" 
End If

MsgBox sTempMsg,vbInformation,sScriptTitle

sTempMsg=""
If sErr<>"" Then sTempMsg="記事取得時のエラー:" & vbCrLf & sErr & vbCrLf
ScriptQuit sTempMsg & "記事取得およびデータ変換が終了しました。"

Sub MakeMsgFile(sStr,iList)

	'sStrを<hr>をスプリッタとして切り分ける。
	'この正規表現は、えらいことになるので素直にプログラムで処理。
	aMsg=Split(sStr,"<hr>",-1,1)

	For Each sMsg In aMsg
		If InStr(1,sMsg,"<blockquote>",1)>0 Then
			
			'記事番号
			regEx.Pattern="<\!-- (\d+) -->"
			iNumber=CInt(regEx.Execute(sMsg)(0).SubMatches(0))
			
			'この記事が変換済みかどうかを確認
			If iList * 100 + iNumber > iOldList * 100 + iOldNumber Then
			
				'From:
				regEx.Pattern="<FONT SIZE=""4"">(.*)<\/FONT>"
				sFrom = Chr(34) & regEx.Execute(sMsg)(0).SubMatches(0) & Chr(34)
				
				regEx.Pattern="\(<A HREF=""mailto\:(.*)"">.*<\/A>\)"
				Set Matches=regEx.Execute(sMsg)
				If Matches.Count>0 Then
					sFrom= sFrom & " <" & Matches(0).SubMatches(0) & ">"
				Else
					sFrom= sFrom & " <someone@somewhere.com>"
				End If
				
				'Subject:
				'この掲示板はタイトルがつかないので、最初の一行をSubject:とする
				sSubject="[" & iList & "-" & iNumber & "] "
				regEx.Pattern="<blockquote>\n([^。\n<]*)(?:。|\n|<)"
				Set Matches=regEx.Execute(sMsg)
				If Matches.Count>0 Then
					sSubject= sSubject & Matches(0).SubMatches(0)
				End If
				
				'Date:
				'2001年 01月 03日 18時 17分 39秒の形式を、14 Dec 1999 08:01:23 +0900にする
				regEx.Pattern="<\!-- DATE=(\d{4})年 (\d{2})月 (\d{2})日 (\d{2})時 (\d{2})分 (\d{2})秒 -->"
				Set Subs=regEx.Execute(sMsg)(0).SubMatches
				sDate = Subs(2) & " " & GetMonthName(Subs(1)) & " " & Subs(0) & " " & Subs(3) & ":" & Subs(4) & ":" & Subs(5) & " +0900"
				'Message-ID:
				'ようするに、時間 & PROCESS_ID & wshlab@wshlab.ne.jp で重複しないと思う。
				sMsgid="<" & Subs(0) & Subs(1) & Subs(2) & Subs(3) & Subs(4) & Subs(5)
				regEx.Pattern="<\!-- (?:.|\n)*PROCESS_ID=(\d+)\n  -->"
				sMsgid=sMsgid & regEx.Execute(sMsg)(0).SubMatches(0) & ".wshlab@wshlab.ne.jp>"
				'本文
				regEx.Pattern="<blockquote>((?:.|\n)*)<\/blockquote>"
				sBody=regEx.Execute(sMsg)(0).SubMatches(0)
				'署名
				sBody=sBody & vbCrLf & "-- " & vbCrLf
				'メールアドレス
				regEx.Pattern="\(<A HREF=""(mailto\:.*)"">.*<\/A>\)"
				Set Matches=regEx.Execute(sMsg)
				If Matches.Count>0 Then
					sBody=sBody & Matches(0).SubMatches(0) & vbCrLf
				End If
				'URL
				regEx.Pattern="URL\:<A HREF\=""(.*)"">"
				Set Matches=regEx.Execute(sMsg)
				If Matches.Count>0 Then
					sBody=sBody & Matches(0).SubMatches(0) & vbCrLf
				End If
				'本文のLine数
				regEx.Pattern = "\n"
				Set Matches = regEx.Execute(sBody)
				iLines=Matches.Count+1
				'タグをとってみる
				regEx.Pattern="<[^>]*>"
				sBody=regEx.Replace(sBody,"")
				'&gt;と&lt;と&amp;を元に戻す
				regEx.Pattern="\&gt\;"
				sBody=regEx.Replace(sBody,">")
				regEx.Pattern="\&lt\;"
				sBody=regEx.Replace(sBody,"<")
				regEx.Pattern="\&amp\;"
				sBody=regEx.Replace(sBody,"&")
				
				'一応一つのメッセージの要素はすべてそろった。組み立てよう。
				sMsg="From: " & sFrom & vbCrLf & _
				"Subject: " & sSubject & vbCrLf & _
				"Date: " & sDate & vbCrLf & _
				"Lines: " & iLines & vbCrLf & _
				"Message-ID: " & sMsgid & vbCrLf & _
				"Content-Type: text/plain; charset=Shift_JIS" & vbCrLf & _
				sBody
				
				If iMode=0 Then 'mbx形式で保存する場合
					
					If iList=iLists+1 And iNumber=iCurNumber Then
						sList = sMsg & vbCrLf & sList '最新記事の場合はスプリット文字なし
					Else
						sList = sMsg & vbCrLf & sSplitChr & vbCrLf & sList 'スプリット文字を書き込む
					End If
									
					'512bytes境界を判別
					'iSect=LenB(sMsg) \ 512
					'sMsg=sMsg & Space(LenB(sMsg) mod 512)
					'そうか、WSHは内部的にUNICODEで文字列を扱うから、文字列のバイト数が調べられない!
					'よって、*.idxを作るのはあきらめる(^^; インポートしてください。

				Else 'eml形式で保存する場合
					Set ts=Fs.CreateTextFile (sEMLDir & iList & "-" & iNumber & sEMLExt,True)
					ts.Write sMsg
					ts.Close
				End If
			End If
		End If
	Next
	If iMode=0 Then 'mbx形式で保存する場合
		tsMBX.Write sList
	End If
End Sub

Function GetHTMLDocument(sURL,sFileName)
On Error Resume Next
	Set xh = WScript.CreateObject("microsoft.xmlhttp")
	xh.Open "GET", sURL, False
	xh.Send
	If Err.Number<> 0 Then
		sErr=sErr & sURL & ": " & Err.Description
		GetHTMLDocument=""
		Exit Function
	End If
On Error Goto 0
	Set ts=Fs.CreateTextFile(sFileName,True,True) 'UNICODEとして書き込む
	ts.Write xh.responseBody
	ts.Close

	Set ts=Fs.OpenTextFile(sFileName,1,False,0) 'SJISとして読む
	If Not ts.AtEndOfStream Then
	    ts.Read(2) '2バイトのごみ(UNICODEヘッダ?)
	    If Not ts.AtEndOfStream Then
	        sTempStr = ts.ReadAll
	    End If
	End If
	ts.Close
	
	Set ts=Fs.CreateTextFile(sFileName,True,False) 'SJISとして保存
	ts.Write sTempStr
	ts.Close
	GetHTMLDocument=sTempStr
End Function

Function GetMonthName(sMonth)
	Select Case sMonth
		Case "01" GetMonthName="Jan"
		Case "02" GetMonthName="Feb"
		Case "03" GetMonthName="Mar"
		Case "04" GetMonthName="Apr"
		Case "05" GetMonthName="May"
		Case "06" GetMonthName="Jun"
		Case "07" GetMonthName="Jul"
		Case "08" GetMonthName="Aug"
		Case "09" GetMonthName="Sep"
		Case "10" GetMonthName="Oct"
		Case "11" GetMonthName="Nov"
		Case "12" GetMonthName="Dec"
	End Select
End Function

Sub ScriptQuit(sSaveMessage)
	If WScript.Arguments.Count >0 Then
		sTempFileName=WScript.Arguments(0)
		If Left(sTempFileName,1)="/" Then
			sTempFileName=Right(sTempFileName,Len(sTempFileName)-1)
			Set ts=Fs.CreateTextFile(sTempFileName,True)
			ts.Write sSaveMessage
			ts.Close
		End If
	End If
	WScript.Quit
End Sub

Sub readfile(path)
	Set ts=Fs.OpenTextFile(path,1)
	Do While ts.AtEndOfStream <> True
		tmp=ts.ReadLine
		tmp=Trim(tmp)
		If Len(tmp)<>0 Then
			urlList(UBound(urlList))=tmp
			Redim Preserve urlList(UBound(urlList)+1)
		End If
	Loop
	ts.Close
End Sub


Sub renketu(tuika,moto)
	Set su = Fs.OpenTextFile(tuika)
	suStr = su.ReadAll

	Set te = Fs.OpenTextFile(moto, 8, False) '8=ForAppending, False=noCreate
	te.Write suStr

	te.Close
	su.Close
End Sub