選択したフォルダーとそのサブフォルダーのすべてのアイテムを HTML ファイルとして連番付きで保存するマクロ


コメントにて以下のご要望をいただきました。


突然のコメントを失礼いたします。
  「選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ」を拝見し、
  利用させていただきたいと思うのですが、
  同様の動作で、追加で下記を実現する方法をご教示いただけないでしょうか。
・受信トレイの下の、任意の複数フォルダを選択し、各フォルダ直下の全てのメールを、そのフォルダ階層を保持したまま、任意の保存先に保存する。
・メッセージをHTML形式で保存する。
お手数をおかけして申し訳ありませんが、お知恵を拝借いただけますと幸いです。
  以上、何卒よろしくお願いいたします。


何度も申し訳ありません。「選択したフォルダーとそのサブフォルダーのすべてのアイテムを MSG ファイルとして保存するマクロ」も参照したところ、 ‘ファイルをフォルダに保存 の箇所を、下記とすればHTML形式で保存ができました。大変失礼いたしました。
objItem.SaveAs strFileName & “.html”, olHTML
もう一点、実現できていないことが、メールの保存時に、各フォルダ内のメールの件名の頭に、受信時間が最も古いものから順に番号を付けたい(例:”1_XXXXX.html”、”2_XXXXX.html”…)という要件です。
もし、実現方法がありましたら、ご教示いただけますと幸いです。
以上、何卒よろしくお願いいたします。


受信時間が最も古いものから順に連番を付けるには、Items オブジェクトの Sort メソッドで受信日時により並べ替えを行い、その順番で連番を付与します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Sub SaveCurrentFolderAndSubToDiskHTML()
     Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
     SaveFolderRecursiveHTML ActiveExplorer.CurrentFolder, SAVE_PATH
End Sub
' フォルダーのアイテムを再帰的に保存するルーチン
Private Sub SaveFolderRecursiveHTML(objFolder As Folder, strSavePath As String)
     On Error Resume Next
     Dim colItems As Items
     Dim objItem 'As MailItem
     Dim strFileName As String
     Dim c As Integer
     Dim i As Integer
     Dim arrErrChars
     Dim objFSO
     Dim objSubFolder As Folder
     arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
     ' アイテムを受信日時の古い順に並べ替える
     Set colItems = objFolder.Items
     colItems.Sort "[受信日時]", False
     ' 連番の初期値設定
     c = 1
     '
     For Each objItem In colItems
         ' ファイル名を件名から作成
         strFileName = c & "_" & objItem.Subject
         ' ファイル名として不適切な文字を _ に置き換える
         For i = 0 To UBound(arrErrChars)
             strFileName = Replace(strFileName, arrErrChars(i), "_")
         Next
         ' ファイル名が 260 文字を超えないようにする
         strFileName = Left(strSavePath & strFileName, 250)
         ' ファイルをフォルダに保存
         objItem.SaveAs strFileName & ".html", olHTML
         c = c + 1
     Next
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     ' サブフォルダーを保存
     For Each objSubFolder In objFolder.Folders
         ' ディスク上にフォルダーが存在しなければ作成する
         If Not objFSO.FolderExists(strSavePath & objSubFolder.Name) Then
             objFSO.CreateFolder strSavePath & objSubFolder.Name
         End If
         SaveFolderRecursiveHTML objSubFolder, strSavePath & objSubFolder.Name & "\"
     Next
End Sub

マクロの登録方法やメニューへの追加について

広告

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

w

%s と連携中