選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ


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


Outlook2003を使用しているのですが、社内ではメールを一通一通、個別のファイルとしてネットワークドライブに保存する習慣があります。
エクスプローラで保存先フォルダを開き、Outlookからドラッグするのですが、その際のファイル名が「件名.msg」から変更することができず、手動で変更する必要があります。(受信日時_差出人_件名.msgというファイル名で保存したいと考えています)
そこで、「受信トレイのすべてのメッセージを MSG ファイルとして保存するマクロ」の、保存ファイル名を変更して「受信日時_差出人_件名.msg」というファイル名でメールを保存するボタンを作成し、使用していますが、表示しているフォルダ内のメールがすべて保存されるため、選択したメールのみを保存するようなマクロの作成をお願いしたいです。
基本的には上記マクロと同様で、保存対象を選択したメールのみに変更したいのですが、当方、マクロの知識が全くなく(エクセルでマクロの記録をしたことがある程度)、変更方法がわからず悩んでいます。
作成したいマクロの条件としては、以下のようなものです。
1)選択したメールのみを保存する
2)複数選択の場合は選択したメールがすべて保存される
3)保存先はマクロ内にパスを指定する形で(上記マクロと同様)
4)マクロの変更でmsg形式とrtf形式両方が(排他で)指定できる



マクロは以下の通りになります。MSG ファイルとして保存する場合は SaveSelectedItemsAsMSG を、RTF ファイルとして保存する場合は SaveSelectedItemsAsRTF を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' MSG として保存するマクロ
Sub SaveSelectedItemsAsMSG()
    SaveSelectedItemsToDisk(olMSGUnicode)
End Sub 
'
' RTF として保存するマクロ
Sub SaveSelectedItemsAsRTF()
    SaveSelectedItemsToDisk(olRTF)
End Sub
'
' 保存するマクロのメイン
Sub SaveSelectedItemsToDisk(saveAsType As OlSaveAsType)
    On Error Resume Next
    Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
    Dim objItem 'As MailItem
    Dim strFileName As String
    Dim i As Integer
    Dim arrErrChars
    Dim objFSO 
    Dim strExt
    If saveAsType = olRTF Then
        strExt = ".rtf"
    Else
        strExt = ".msg"
    End If
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' 現在表示中のフォルダで選択されたアイテムについて
    For Each objItem In ActiveExplorer.Selection
        ' ファイル名を受信日時と件名から作成
        strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする
            strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhnn_")
            Err.Clear
        End If
        strFileName = strFileName & objItem.SenderName & "_" & objItem.Subject  
        ' ファイル名として不適切な文字を _ に置き換える
        For i = 0 To UBound(arrErrChars)
            strFileName = Replace(strFileName, arrErrChars(i), "_")
        Next
        ' ファイル名が 260 文字を超えないようにする
        strFileName = Left(SAVE_PATH & strFileName, 250)
        ' 同名のファイルがある場合の処理
        If objFSO.FileExists(strFileName & strExt) Then
            i = 2
            ' (2) から始める
            While objFSO.FileExists(strFileName & "(" & i & ")" & strExt)
                i = i + 1
            Wend
            strFileName = strFileName & "(" & i & ")"
        End If
        ' ファイルをフォルダに保存
        objItem.SaveAs strFileName & strExt, saveAsType
    Next
End Sub

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

広告

選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ」への7件のフィードバック

  1. お世話になっております。
    いつもこちらのサイトを参考にさせて頂いております。

    当方Outlook2003で上記マクロを使用させて頂いているのですが、
    こちらのマクロは1度に保存するメッセージ数に上限はあるのでしょうか?

    375件のメッセージを選択し保存しようとすると、245件しか保存されなくて困っております。
    保存メッセージ数を変えても、最大245件となってしまいます。

    • メッセージの上限は特にないと思うのですが、もしかするとメモリの制限などによって処理ができなくなるのかもしれません。
      お手数ですが200件ぐらいずつ保存するようにしてみてください。

  2. 上記マクロでメッセージをフォルダへ保存したあとに、Outlookのメッセージを削除することはできますでしょうか?

    • End Sub の直前に以下の記述を追加すれば削除できるでしょう。

      For i = ActiveExplorer.Selection.Count To 1 Step -1
      ActiveExplorer.Selection(i).Delete
      Next

  3. ありがとうございます。
    試してみたのですが、削除したメールがなぜか2つに増えます。
    ゴミ箱に入っているので、ゴミ箱を空にすればいいだけなのですが、、、

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中