'名  前:MHTで保存
'作成日:2006/05/20
'修正日:2006/06/07
'作成者:Eclipse
'※概要※
'表示中のページをフォルダを指定してに[年月日_時分秒_タイトル.mht]のファイル名でMHT形式で保存
'保存が完了するとサウンドを鳴らす
'※変更点※
'2006/06/07 選択文字列有無の判別ルーチンをActiveFrameDocumentを用いたものに変更
'           選択文字列からファイル名に使えない文字列を除去するルーチンを追加
'           選択文字列を保存(ParamStr(0)=3の場合)の処理がおかしかった部分を修正


Option Explicit

'■■ 定数宣言 ■■
'Default保存先フォルダ(フォルダ選択ダイアログのRootフォルダを設定)
Const SAVE_DIR = ""
'決めうち保存先フォルダ
Const SAVE_POS = ""
'サウンドファイル(保存終了時に演奏するWaveファイルを設定)
Const SOUND_FILE = "C:\Windows\Media\Notify.wav"

'ダウンロード要素列挙
Const DL_PICTURE = 1  '画像
Const DL_SOUND   = 2  'BGM
Const DL_FRAME   = 4  'フレーム内
Const DL_OBJECT  = 8  'オブジェクト(FLASHなど)
Const DL_CSS     = 16 'スタイルシート

'日時取得関数用
Const DATE_FOR_FILE = 1
Const DATE_FOR_HTML = 2

'FileSystemObject用
Const ForReading = 1

'■■ 変数宣言 ■■
Dim strPath, DL_FACTOR

'■■ 事前準備 ■■
'DL要素
DL_FACTOR = (DL_PICTURE OR DL_CSS OR DL_FRAME)

'Default保存フォルダの確認・設定
If SAVE_DIR = "" Then
  strPath = PathScrapbook
Else
  strPath = SAVE_DIR
End If

'■■ メインルーチン呼び出し ■■
'引数確認
If ParamCount = 0 Then
  MsgBox "引数無いよ"
ElseIf ParamCount > 3 Then
  MsgBox "引数大杉"
Else
  '条件によってScriptを終了するため、メインルーチンをMain()として切り分ける
  Call Main()
End If

'■■ メインルーチン ■■
Private Sub Main()
  Dim objShell, objFol, strTitle, objDoc
  Dim strDate, strFileName, Ret, objRange, strRange, strCmd, strURL

  '■フォルダ選択保存か選択範囲保存の場合ダイアログ表示
  If (ParamStr(0) = 2) Or (ParamStr(0) = 3) Then
    'フォルダ選択ダイアログの表示
    Set objShell = CreateObject("Shell.Application")
    '保存先フォルダの取得 //第2引数(ダイアログスタイル)は BIF_NEWDIALOGSTYLE OR BIF_USENEWUI
    Set objFol = objShell.BrowseForFolder(Handle,"フォルダ選択", 80, strPath)

    'Cancelが押された場合
    If objFol Is Nothing Then
      'Scriptから抜ける
      Exit Sub
    Else
      strPath = objFol.Items().Item().Path
    End If
  End If

  '■Documentオブジェクトの取得
  Set objDoc = ActiveDocWin

  '■タイトルの取得
  strTitle = GetCorrectFileName(objDoc.Title)

  '■選択文字列がある場合、それをファイル名に含めるかどうかを問い合わせ
  If ParamStr(0) <> 3 Then
    strRange = CheckSelected(objDoc.ActiveFrameDocument)
    strTitle = SetSelectedAsTitle(strRange, strTitle)
  End If

  '■URLの取得
  strURL = objDoc.URL

  '■年月日＆時刻データ作成
  strDate = GetDateStr(DATE_FOR_FILE)

  '■ファイル名生成＆保存
  '引数によって処理分岐
  Select Case ParamStr(0)
    Case 1  'ファイル決めうち保存(Junk)
      strFileName = SAVE_POS & "\" & strDate & strTitle
      Ret = objDoc.SaveBySBK(strFileName ,DL_FACTOR, ParamStr(1))
    Case 2  'フォルダ選択保存
      strFileName = strPath & "\" & strDate & strTitle
      Ret = objDoc.SaveBySBK(strFileName ,DL_FACTOR, ParamStr(1))
    Case 3  '選択範囲保存
      strFileName = strPath & "\" & strDate & strTitle
      Ret = objDoc.SaveSelectionToFile(strFileName, DL_FACTOR, ParamStr(1))
    Case Else
      MsgBox "引数間違い"
      Exit Sub
  End Select

  '■MHTファイルにOriginal URLと保存時間を挿入
  If ParamStr(2) = 1 Then
    Ret = InsertOriginalInfo(strURL, strFileName)
  End If

  '■サウンドを鳴らす
  PlaySound SOUND_FILE
End Sub


'■■ 関数 ■■
'## 選択文字列を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 GetDateStr(STR_TYPE)
  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 STR_TYPE = 1 Then
    'ファイル名用文字列
    GetDateStr = YY & MM & DD & "_" & HH & NN & SS & "_"
  ElseIf STR_TYPE = 2 Then
    'HTML用文字列
    GetDateStr = 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

'## Original URLと時間を挿入したMHTファイル作成 ##
Private Function InsertOriginalInfo(argURL, argFileName)
  Dim objFSO, objStrm, strText, strPutText
  Set objFSO = CreateObject("Scripting.FileSystemObject")

  'ファイルを開く
  Set objStrm = objFSO.OpenTextFile(argFileName, ForReading)
  strText = objStrm.ReadAll()

  '挿入用文字列作成
  strPutText = "<BR>Original URL: <A Href=" & Chr(34) & argURL & "#" & Chr(34) & " Target""_top"">" & argURL & "#" & "</A><BR>" & Chr(13) & Chr(10)
  strPutText = strPutText & "Time : " & GetDateStr(DATE_FOR_HTML) & Chr(13) & Chr(10) & "</Body>"

  'ストリーム中の</body>タグを探し、直前にOriginal URLと時間を挿入
  strText = Replace(strText, "</body>", strPutText, 1, -1, vbTextCompare)

  'ファイルを作る
  Set objStrm = objFSO.CreateTextFile(argFileName, True)
  objStrm.Write strText

  InsertOriginalInfo = True
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