Outlook 研究所

2016年11月26日

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


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


初めまして。仕事でOutlook2013を利用しています。(ExchangeServer2013環境だと思われます。)
日々、大量のメールが届くため、PC本体に受信メールを自動保存する方法がないかと思い、次のマクロを参考にさせてもらいました。
⇒2010年11月18日「選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ
ファイル名として、送信者の部署名を入れたいのですが可能でしょうか。
これまでの問合せを見たところ、部署名はExchangeUserオブジェクトのDepartmentプロパティにあることはわかりましたが、どのように取得すればよいのか(取得可能なのかも含めて)わかりません。ご教授願います。



送信者の情報は MailItem の Sender プロパティで取得可能です。
そして、送信者の部署名については、Sender の GetExchangeUser メソッドで ExchangeUser オブジェクトを取得し、その Department プロパティにより参照可能です。
選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロをファイル名に部署名を入れるよう修正したものは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' 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 strDept As String
    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
        ' 差出人の部署名を取得
        strDept = ""
        If objItem.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
            strDept = objItem.Sender.GetExchangeUser().Department & "_"
        End If
        ' ファイル名を受信日時、部署名と件名から作成
        strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする
            strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhnn_")
            Err.Clear
        End If
        strFileName = strFileName & strDept & 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

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

コメントする »

まだコメントはありません。

RSS feed for comments on this post. TrackBack URI

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中

WordPress.com で無料サイトやブログを作成.

%d人のブロガーが「いいね」をつけました。