'WSHLab掲示板の記事MUAで読むスクリプト ' 'WSHLab.掲示板(http://www.roy.hi-ho.ne.jp/mutaguchi/bbs/index.shtml)にアクセスし、 '記事を取ってきて、mbx形式もどきあるいはeml形式に変換するスクリプトです。 ' '[使い方] '***必ず新しいフォルダを作って、wshbbs.vbsをそこに移動してから***、 'wshbbs.vbsを実行します。あとはダイアログの指示に従ってください。 ' 'mbx形式で保存する場合、取得記事がWSHLabBBS.txtというファイルにまとめられます。この場合、 '各記事は"."(ピリオド)で区切られます。 '生成されるWSHLabBBS.txtは、まったくMIMEエンコードすらされていないShift_JISファイルです。 'そのため、このファイルをmbxファイルとして認識するには、特殊なツール(nkf等)が必要になる場合も 'あることをご承知ください。(WSHの標準機能のみでは、技術的な限界があったもんで) 'Datula ver1.5以降であれば、特に手直しせずインポートすることが可能です。 'アーカイブアカウントを作成し、その中にフォルダを作成し、WSHLabBBS.txtを 'インポートします。その際、境界の文字列として"."(ピリオド)を指定します。 'EdMax ver 2.74でもインポートできることを確認しています。 ' 'eml形式で保存する場合、取得記事はそれぞれ拡張子emlのファイルとして、emlfilesフォルダの '直下に作成されます。 'この*.emlファイルは、Outlook Expressのフォルダにまとめてドラッグアンドドロップすることで 'インポートできます。(OE5.5で動作確認) ' 'mbx形式、eml形式どちらに変換するかは、このスクリプト内で、iMode変数の値を変えることで '決められます。(「変更可能項目」のコメントがある行です) 'デフォルトでは、mbx形式で出力します。 'また、各ファイル名やパス等は、同様にスクリプトを一部書き換えることで、 'ある程度簡単に変更することができます。 ' 'このスクリプト実行後は、wshbbs.iniというファイルに、現在までに変換した記事の情報を '記録し、次回からはそれ以降の記事の取得を試みます。 '(その際、WSHLabBBS.txt、*.emlは上書きされます) 'wshbbs.iniには、 '最新記事のリスト番号-最新記事の記事番号 'という形式で保存されます。リスト番号とは、過去記事リストの数を1から順に振ったもので、 '最新記事のリスト番号は、最新の過去記事のリスト番号(変な日本語(^^;)+1になります。 '記事番号は、リスト中におけるメッセージの番号です。この番号は1から50までになります。 'wshbbs.iniを削除して実行すると、すべての記事が含まれたWSHLabBBS.txt、あるいは*.emlを '作成できます。 ' 'なお、ダウンロードがうまくいかない場合は、IEを立ち上げ「オンラインモード」にしてください。 ' '[必要環境] 'Windows Script5.5+IE5.0以上もしくはIE5.5がインストールされているWin98/Me/2000 ' '[付記] 'AKiOSさんのWSHLab.掲示板記事検索スクリプト(HTA)と併用する場合は、 'WshLab.iniファイル(WSHLab.掲示板記事検索スクリプトが作成する設定ファイル)に 'download.command=wscript.exe wshbbs.vbs /"%tmpfile%" 'という行を追加してください。wshbbs.vbsは、WshLab.htaと同じフォルダに入れます。 ' '[更新履歴] '2001/01/04 ver 1.00 作成 '2001/01/05 ver 1.10 Outlook Expressに対応(eml形式の出力が可能に) ' mbx形式ファイルのバックアップをとるようにした ' Lines:/Message-id:/Content-type:を入れてみた。うそっぽいですが。 '2006/09/29 WshLab.htaと併用する際は、download.command=wscript.exe wshbbs.vbs /"%tmpfile%" のように""でくくるように推奨 ' 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="" '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を
をスプリッタとして切り分ける。 'この正規表現は、えらいことになるので素直にプログラムで処理。 aMsg=Split(sStr,"
",-1,1) For Each sMsg In aMsg If InStr(1,sMsg,"
",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>" sFrom = Chr(34) & regEx.Execute(sMsg)(0).SubMatches(0) & Chr(34) regEx.Pattern="\(.*<\/A>\)" Set Matches=regEx.Execute(sMsg) If Matches.Count>0 Then sFrom= sFrom & " <" & Matches(0).SubMatches(0) & ">" Else sFrom= sFrom & " " End If 'Subject: 'この掲示板はタイトルがつかないので、最初の一行をSubject:とする sSubject="[" & iList & "-" & iNumber & "] " regEx.Pattern="
\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="
((?:.|\n)*)<\/blockquote>" sBody=regEx.Execute(sMsg)(0).SubMatches(0) '署名 sBody=sBody & vbCrLf & "-- " & vbCrLf 'メールアドレス regEx.Pattern="\(.*<\/A>\)" Set Matches=regEx.Execute(sMsg) If Matches.Count>0 Then sBody=sBody & Matches(0).SubMatches(0) & vbCrLf End If 'URL regEx.Pattern="URL\:" 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,"") '>と<と&を元に戻す regEx.Pattern="\>\;" sBody=regEx.Replace(sBody,">") regEx.Pattern="\<\;" sBody=regEx.Replace(sBody,"<") regEx.Pattern="\&\;" 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