選択したメッセージをファイル名に部署名をつけて 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

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

受信した Excel ファイルを印刷するマクロ

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


outlook2010で2つのメールアドレスを使用しています。その片方のメールアドレスに届いたエクセルファイルだけ自動で印刷するということをしたいです。

このようなマクロを作成していただけないでしょうか?



2 つのメールアドレスを使用するというのが、以下のどちらのことを意味しているのかがちょっと分かりかねましたので、ルールで実行するマクロにしました。

  • 一つのアカウントに複数のメールアドレスが受信される
  • 二つのアカウントでそれぞれに受信される

以下のようなマクロを定義し、「受信者のアドレスに特定の文字が含まれる場合」や「指定されたアカウントを経由した場合」の条件で実行されるルールのアクションの「スクリプトを実行する」のスクリプトとして、PrintExcelAttach を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                (ByVal hwnd As Long, ByVal lpszOp As String, _
                 ByVal lpszFile As String, ByVal lpszParams As String, _
                 ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                 As Long
'
Public Sub PrintExcelAttach(ByRef objItem As MailItem)
    On Error Resume Next
    Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.xls*" Then
            ' ファイルが Excel の場合のみ保存して印刷
            c = 1
            With objAttach
                strFileName = .FileName
                While objFSO.FileExists(ATTACH_PATH & strFileName)
                    strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                        & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                    c = c + 1
                Wend
                .SaveAsFile ATTACH_PATH & strFileName
            End With
            '    保存したファイルを印刷する
            ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
        End If
    Next
End Sub

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

Outlook.com の文字化け解消方法

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


はじめまして。困っていますので、助けて下さい。
outlook2013で、outlook.comのアカウントを使用しています。
数日前に送信できなくなったため、いろいろ試行錯誤した挙句、outlook2013で改めてアカウントを設定したところ、無事に送信できるようになりました。
恐らく、それからのことだと思いますが、
受信したメールにフラグを設定すると、そのメールだけ、差出人、受信者、件名、添付ファイル名のいずれか、もしくはすべてで文字化けします。
本文は正常のままです。
フラグを設定したメールの全てではありませんが、文字化けしないものは少数です。
何か対策はないものでしょうか?

申し訳ありません。書き忘れたことがありました。
outlook.comのアカウントなので、Exchange Active Syncによる接続です。
また、outlook.comですので、webでの操作が可能ですが、
webでは文字化けしておりません。
また、iphoneのメールアプリも利用していますが、
こちらでも文字化けしていません。
どうか、宜しくお願いします。



Exchange Active Sync は、本来 Exchange サーバーとモバイル製品のメールや予定の同期のために開発されたプロトコルであり、Outlook で Exchange Active Sync を使うといろいろ問題が起こるようです。
そのため、Outlook.com は現在 Office 365 のプラットフォームへの移行作業が進められており、Office 365 へ移行後はサーバーとの接続が Exchange Active Sync ではなく MAPI/HTTP に変わります。
MAPI/HTTP は以前から Exchange と Outlook の通信に使用されていた MAPI を HTTP ベースに実装したプロトコルであり、おそらく MAPI/HTTP に切り替わればこのような文字化けは発生しなくなると思います。
もし、Web 版の Outlook.com に接続して、左上のバナーに「Outlook メール」と表示されているのであれば移行済みですが、「Outlook.com」となっている場合は古いサーバーに接続されている状態です。
来年の半ばには全体が移行するようですが、以下の URL を表示すると明示的に移行が行われるようです。

http://mail.live.com/default.aspx?owaoptin=1

上記の URL を表示し、バナーで移行が完了したのを確認してから Outlook.com のアカウントを再作成し、MAPI/HTTP で接続して現象が回避できるか確認してみてください。

Outlook 2016/2013 の累積的な修正プログラム 2016 年 11 月分がリリース

11/1 に Office 2016 および Office 2013 の累積的な修正プログラムがリリースされました。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

November 1, 2016, update for Outlook 2016 (KB3127912)
9 件の不具合修正と 1 件の機能追加が行われています。

Word 2016 の修正

November 1, 2016, update for Word 2016 (KB3127941)
Outlook 2016 関連の不具合が 2 件修正されています。

Office 2016 共通コンポーネントの修正

November 1, 2016, update for Office 2016 (KB3118336)
November 1, 2016, update for Office 2016 (KB3118338)
November 1, 2016, update for Office 2016 (KB3118340)
それぞれ、Outlook 2016 関連の不具合が 1 件ずつ修正されています。

Office 2013

Outlook 2013 の修正

November 1, 2016, update for Outlook 2013 (KB3127919)
8 件の不具合修正と 1 件の機能追加が行われています。

仕訳ルールでメールの本文と PDF のみ印刷するマクロ

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


毎回、こちらのサイトにとてもお世話になっております。どうしてもお力添えいただきたく質問させていただきました。
・ 仕様環境 Win10(32bit) OUTLOOK2010
マクロは使用せず、仕分けルールと印刷設定を利用しまして、メールを受信したら添付ファイルごと自動で全て印刷をしております。
この際、【メール本文+PDF】は印刷したいのですが、それ以外の添付ファイル(doc、docx、xls、xlsx、ppt、pptx、zip、csv、exe 等)は印刷しないで無視するように設定できないものか苦慮しております。
このような都合の良いマクロを作りたいと考えているのですが、何か良い方法はございますでしょうか。



ルールの指定では特定の種類のファイルだけ印刷しないというようなことはできないので、本文の印刷と添付ファイルが pdf のときだけ保存して印刷をするというマクロを作成し、それをルールの条件として呼び出すことでご要望の動作ができると思います。
以下のマクロを設定し、ルールの条件で [スクリプト] としてマクロの名前を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                (ByVal hwnd As Long, ByVal lpszOp As String, _
                 ByVal lpszFile As String, ByVal lpszParams As String, _
                 ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                 As Long
'
Public Sub PrintBodyAndPDFAttach(ByRef objItem As MailItem)
    On Error Resume Next
    Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    ' 本文を印刷
    objItem.PrintOut
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.pdf" Then
            ' ファイルが PDF の場合のみ保存して印刷
            c = 1
            With objAttach
                strFileName = .FileName
                While objFSO.FileExists(ATTACH_PATH & strFileName)
                    strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                        & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                    c = c + 1
                Wend
                .SaveAsFile ATTACH_PATH & strFileName
            End With
            '    保存したファイルを印刷する
            ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
        End If
    Next
End Sub

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

深い階層のフォルダーを一度に作成するマクロ

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


お世話になっております。Outlook 2013 または 2016 で、受信トレイのサブフォルダーとして作成したフォルダー A に対して、さらに多階層のサブフォルダーを一括作成したいと考えています。
具体的には、フォルダー A のサブフォルダーとしてサブフォルダー B を、そして、サブフォルダー B のサブフォルダーとしてさらにサブフォルダー C を、、、という感じで、3~4 階層程度のサブフォルダーを作成する方法をご教示くださいますようお願いいたします。
よろしくお願いします。



Outlook の標準機能ではフォルダーは 1 度に 1 つしか作れないため、ご要望のような動作を満たすにはマクロを作る必要があります。
例えば、現在選択中のフォルダーの下に、入力した文字列を ¥ で区切ったフォルダー階層を作成するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CreateDeepSubFolder()
    On Error Resume Next
    Dim fldRoot As Folder
    Dim fldSub As Folder
    Dim strPath As String
    Dim astrFolders As Variant
    Dim strSub As Variant
    '
    strPath = InputBox("フォルダー パス")
    If strPath <> "" Then
        astrFolders = Split(strPath, "¥")
        Set fldRoot = ActiveExplorer.CurrentFolder
        For Each strSub In astrFolders
            Set fldSub = Nothing
            Set fldSub = fldRoot.Folders(strSub)
            If fldSub Is Nothing Then
                Set fldSub = fldRoot.Folders.Add(strSub)
            End If
            Set fldRoot = fldSub
        Next
    End If
End Sub

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

会議出席依頼にフラグを付けるマクロ

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


Outlook2010 で会議出席依頼(MeetingItem)を受信した時に、フラグを付ける(開始日は受信日、期限は会議の日)マクロを作りたいのですが、どうすればよいのでしょうか?



Outlook Object モデルの MeetingItem にはフラグを設定するためのメソッドやプロパティが用意されていません。
そのため、MeetingItem にフラグを付けるには、PropertyAccessor.SetProperty によりいくつかの MAPI プロパティを設定する必要があります。
ご要望のマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Variant
    Set objItem = Session.GetItemFromID(EntryIDCollection)
   
    If TypeName(objItem) = "MeetingItem" Then
        SetStartAndDueDate objItem
    End If
End Sub
'
Private Sub SetStartAndDueDate(ByVal meetItem As MeetingItem)
    Const PidLidToDoTitle = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85A4001E"
    Const PidLidTaskStartDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81040040"
    Const PidLidTaskDueDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81050040"
    Const PidLidReminderSet = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8503000B"
    Const PR_TODO_ITEM_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x0E2B0003&quot;
    With meetItem.PropertyAccessor
        .SetProperty PidLidToDoTitle, meetItem.Subject
        .SetProperty PidLidTaskStartDate, Now
        .SetProperty PidLidTaskDueDate, meetItem.GetAssociatedAppointment(False).Start
        .SetProperty PidLidReminderSet, True
        .SetProperty PR_TODO_ITEM_FLAGS, 1
    End With
    meetItem.Save
End Sub

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