'TabGroupをMHT形式で保存 '作成日:2006/05/22 '修正日:2006/06/07 '作成者:Eclipse '※概要※ '表示しているページから右のページをまとめて新しいTabGroupに移しMHT形式で保存する '※変更点※ '2006/06/07 選択文字列有無の判別ルーチンをActiveFrameDocumentを用いたものに変更 ' 選択文字列からファイル名に使えない文字列を除去するルーチンを追加 Option Explicit '■■ 定数宣言 ■■ Const ForReading = 1, ForWriting = 2 Const TAB_NAME_FOR_SAVE = "保存用タブ" Const SAVE_DIR = "" 'ダウンロード要素列挙 Const DL_PICTURE = 1 '画像 Const DL_SOUND = 2 'BGM Const DL_FRAME = 4 'フレーム内 Const DL_OBJECT = 8 'オブジェクト(FLASHなど) Const DL_CSS = 16 'スタイルシート 'エンコード用要素列挙 Const SAVE_ORIGINAL = 0 Const SAVE_UTF8 = 1 Const SAVE_EUC = 2 Const SAVE_Shift_JIS = 3 Const SAVE_JIS = 4 'サウンドファイル(保存終了時に演奏するWaveファイルを設定) Const SOUND_FILE = "C:\Windows\Media\Notify.wav" '■■ 事前準備 ■■ 'DL要素 Dim DL_FACTOR DL_FACTOR = DL_PICTURE OR DL_CSS OR DL_FRAME 'Default保存フォルダの確認・設定 Dim strPath If SAVE_DIR = "" Then strPath = PathScrapbook Else strPath = SAVE_DIR End If '■■ メインルーチン呼び出し ■■ Call Main() '■■ メインルーチン ■■ Private Sub Main() Dim objDoc, intDocID, objTabGrp, objTemp, dicID, intDocNumber, i, j Dim strURL, Return, objTab, arrData(), strTitle, WShell, objFol Dim objSelect, strSelect '■準備 Set objDoc = ActiveDocWin intDocNumber = 0 j = 0 '■フォルダ選択 'フォルダ選択ダイアログの表示 Set WShell = CreateObject("Shell.Application") '保存先フォルダの取得 //第2引数(ダイアログスタイル)は BIF_NEWDIALOGSTYLE OR BIF_USENEWUI Set objFol = WShell.BrowseForFolder(Handle,"フォルダ選択", 80, strPath) 'Cancelが押された場合 If objFol Is Nothing Then 'Scriptから抜ける Exit Sub Else strPath = objFol.Items().Item().Path End If '■現在表示しているドキュメントのIDを取得 intDocID = objDoc.ID '表示しているドキュメントが所属しているTabGroupオブジェクトを取得 Set objTabGrp = TabGroups.ActiveGroup '表示中のページが何番目かを取得するためのループ処理 For Each objTemp In objTabGrp 'すでに取得してあるIDと同じIDを見つけたらループを抜ける If objTemp.ID <> intDocID Then intDocNumber = intDocNumber + 1 Else Exit For End If Next '■新規タブグループ作成 Set objTab = TabGroups.NewGroup(TAB_NAME_FOR_SAVE) '■HTML生成用データ配列の初期化 ReDim arrPage(objTabGrp.Count - intDocNumber -1, 2) '■保存したいページのURLを取得して保存用タブグループで新規Documentを開く For i = intDocNumber To objTabGrp.Count - 1 'URL取得 strURL = objTabGrp.Item(i).URL '新規Document作成 NavigateNew strURL, , , , TAB_NAME_FOR_SAVE 'HTML生成用にURLとTitleを配列に入れる arrPage(j, 0) = j + 1 arrPage(j, 1) = objTabGrp.Item(i).Title '正規表現でURLから#は取っちゃう If InStr(strURL, "#") > 0 Then strURL = Mid(strURL, 1, InStr(strURL, "#") - 1) End If arrPage(j, 2) = strURL j = j + 1 Next '■選択文字列を取得 strSelect = CheckSelected(objDoc.ActiveFrameDocument) '■タイトル取得 strTitle = SetSelectedAsTitle(strSelect, GetCorrectFileName(arrPage(0, 1))) '■HTMLファイル作成 Call MakeHTML(arrPage, strTitle) '■保存ファイルPath取得 strPath = strPath & "\" & MakeDate(1) & strTitle '■保存 Do Until objTab.Item(0).ID = ActiveDocWin.ID objTab.Item(0).SetFocus Loop Return = objTab.SaveAllAsMHT(strPath , DL_FACTOR, SAVE_Shift_JIS) '■サウンドを鳴らす PlaySound SOUND_FILE '■保存用タブグループを閉じる objTab.Close End Sub '■■ サブルーチン ■■ '## Index用HTMLファイルを作成して ## Private Sub MakeHTML(arrData, strListTitle) Const TEMP_FOLDER = 2 Const ForReading = 1, ForAppending = 8 Const DQ = """" Dim objFSO, objText, strTempPath, strTempName, i 'Temporaryフォルダの取得 Set objFSO = CreateObject("Scripting.FileSystemObject") strTempPath = objFSO.GetSpecialFolder(TEMP_FOLDER) '一時ファイル名の生成 strTempName = Replace(objFSO.GetTempName, "tmp", "html") strTempName = strTempPath & "\" & strTempName 'ファイル作成 Set objText = objFSO.CreateTextFile(strTempName, True) 'HTMLを書き込む With objText .WriteLine "" .WriteLine "" .WriteLine "" .WriteLine "" .WriteLine "" .WriteLine "Page_List" .WriteLine "" .WriteLine "" .WriteLine "" 'HTML Body .WriteLine "" .WriteLine "
Saved By ScriptBrowserK
" 'Title .WriteLine "

" .WriteLine "
ファイル名" & strListTitle & "
" 'リストのヘッダ生成 .WriteLine "
保存日時" & MakeDate(2) & "

" .WriteLine "サムネイル画像クリックで保存MHTを表示します" For i = 0 To UBound(arrData) '■サムネイルあり .WriteLine "
" .WriteLine "
No." & arrData(i,0) & "" & arrData(i,1) & "
" .WriteLine "" .WriteLine "" 'サムネイル .WriteLine "
[Original URL]
" .WriteLine "" & arrData(i,2) & "" 'Original URL .WriteLine "
" Next .WriteLine "" .WriteLine "" End With '作成したファイルを開く NavigateNew strTempName, , , , TAB_NAME_FOR_SAVE End Sub '■■ 関数 ■■ '## 年月日＆時刻データ作成 ## Private Function MakeDate(varType) Dim varDate, YY, MM, DD, HH, NN, SS varDate = Now() YY = CStr(Year(varDate)) MM = Right("0" & Month(varDate),2) DD = Right("0" & Day(varDate),2) HH = Right("0" & Hour(varDate),2) NN = Right("0" & Minute(varDate),2) SS = Right("0" & Second(varDate),2) If varType = 1 Then MakeDate = YY & MM & DD & "_" & HH & NN & SS & "_" ElseIf varType =2 Then MakeDate = YY & "/" & MM & "/" & DD & " " & HH & ":" & NN & ":" & SS End If End Function '## ファイル名に使えない文字を変換 ## Private Function GetCorrectFileName(strFileName) strFileName = Replace(strFileName, "|", "_") strFileName = Replace(strFileName, "*", "_") strFileName = Replace(strFileName, "/", "_") strFileName = Replace(strFileName, "<", "[") strFileName = Replace(strFileName, ">", "]") strFileName = Replace(strFileName, ":", "-") strFileName = Replace(strFileName, "\", "-") strFileName = Replace(strFileName, "?", "_") strFileName = Replace(strFileName, Chr(34), "'") strFileName = AvailableFilename(strFileName) GetCorrectFileName = strFileName End Function '## 選択文字列をTitleとして使用するかどうかの問い合わせ ## Private Function SetSelectedAsTitle(strSelect, strTitle) Dim Ret, strTempTitle '選択文字列がある場合、それをファイル名に含めるかどうかを問い合わせ If strSelect <> "" Then Ret = MsgBox("「" & strSelect & "」" & Chr(13) & Chr(10) & _ "この選択文字列をファイル名に含めて保存しますか？", _ 4 OR 32, _ "問い合わせ") '「はい」の場合 If Ret = 6 Then Ret = MsgBox("「" & strTitle & "」" & Chr(13) & Chr(10) & "このタイトルと置き換えますか？", _ 4 OR 32 OR 256, _ "問い合わせ") 'さらに「はい」の場合 If Ret = 6 Then strTempTitle = strSelect & ".mht" '「いいえ」の場合(タイトル＋選択文字列) ElseIf Ret = 7 Then strTempTitle = strTitle & "_" & strSelect & ".mht" End If '「いいえ」の場合 ElseIf Ret = 7 Then strTempTitle = strTitle & ".mht" End If Else strTempTitle = strTitle & ".mht" End If SetSelectedAsTitle = strTempTitle End Function '## 選択文字列があるかどうかの確認 ## Private Function CheckSelected(objActiveFrame) Dim strSelect strSelect = objActiveFrame.Selection.createRange().text '選択文字列があった場合 If strSelect <> "" Then 'ファイル名に使えない文字列を除去 strSelect = GetCorrectFileName(strSelect) '改行を取り除く strSelect = Replace(strSelect, Chr(13), "") 'CR strSelect = Replace(strSelect, Chr(10), "") 'LF '前後の空白(半角・全角とも)を削除 strSelect = Trim(strSelect) End If CheckSelected = strSelect End Function