こんにちは、くのへ@MasazaneKunoheです。
メールを保管したら所定フォルダにも自動保存するマクロを作成しましたので投稿します。

これは、超便利なマクロに仕上がったかもしれません。
やはりニーズを元にしたマクロは良いものができます。

こんなツイート頂きました

このツイート見た時、超笑いましたｗ😆

べ、別にそんなエサ、好きなんじゃないからね！！！🦅バサバサ

、、、

（心の声：ま、まあ、、、嫌いじゃないわよ！！むしろ大好きｗ）
↑ツンデレw

メールを保管⇒所定フォルダにも自動保存

今回のお話は「メール受信時に添付ファイルを指定のフォルダに自動保存」ですが、すべての受信メールに対して自動保存させるのは、なんとな～くマズイ気がします。なんとな～く。

そこで今回は「Outlookフォルダに移動したタイミング（=保管したタイミング）」で自動的に指定のフォルダに自動保存されるようにしました。

準備

受信トレイの下に「分類1」というフォルダを作っておきます。「1」は半角です。別の名前にするとコードをコピペで動かすときにエラーになります。

自動保存するフォルダも作っておきます。ここではデスクトップに「フォルダ名」というフォルダを作りました。

コード

イベントマクロなので、標準モジュールではなくThisOutlookSessionにコーディングしてください。

↓コピペOKです。
ただし、Private Sub Application_Startup()の中のコードはカスタマイズが要ります。
今回は、受信トレイ直下の「分類1」フォルダのItemsをmy分類1Itemsとしてセットしました。別なフォルダにしたい場合は、ここをカスタマイズしてください。
ただし、カスタマイズするためには、若干難しい「Outlookのオブジェクト構造」を理解する必要があります。こちらの記事を参照ください。

'イベント用の「my分類1Item」を作成する
Private WithEvents my分類1Items As Items


Private Sub Application_Startup()
'Outlook起動時に「my分類1Item」オブジェクトを受信トレイ直下の「分類1」フォルダとしてセットする

  Set my分類1Items = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("分類1").Items

End Sub


Private Sub my分類1Items_ItemAdd(ByVal Item As Object)
'受信トレイ直下の「分類1」フォルダにメールが追加された時に「添付保存」サブプロシージャを動作させる。
'なお、追加されたメールを表す引数「Item」を「添付保存」サブプロシージャに渡す
  
  Call 添付保存(Item)

End Sub

以降は標準モジュールに書いてもOKです。（ThisOutlookSessionに書いても動作します）

コードの頭の定数「PATH」は保存したいフォルダのアドレスを記述してください。

Sub 添付保存(ByVal Item As Object)

'保存先アドレスを定数PATHに登録
Const PATH As String = "C:\Users\ユーザ名\Desktop\フォルダ名"

'フォルダ名はメール受信日yyyymmdd＋件名とする
  Dim strItemPath As String
  strItemPath = PATH & "\" & Format(Item.ReceivedTime, "yyyymmdd_") & Item.Subject
  
  strItemPath = 重複処理(strItemPath)

'フォルダを作ってメール本体を保存する
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strItemPath
  
  Item.SaveAs strItemPath & "\" & Item.Subject & ".msg"

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

  With Item
    For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
        Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then

            strFile = strItemPath & "\" & objAttachment.FileName
            strFile = 重複処理(strFile)
            objAttachment.SaveAsFile strFile

        End If
    Next objAttachment
  End With
  
  '各オブジェクト達をNothingで消しておく
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub


Function 重複処理(ByVal strName)

 '同名ファイル・フォルダがあれば通し番号を追加

  Dim strCheckName As String
  Dim i As Integer

  strCheckName = strName
  
  i = 1
    
  Do While Dir(strCheckName, vbDirectory) <> ""
    If InStr(strCheckName, ".") <> 0 Then
      strCheckName = Left(strName, InStrRev(strName, ".") - 1) & "(" & i & ")" & Mid(strName, InStrRev(strName, "."))
    Else
      strCheckName = strName & "(" & i & ")"
    End If
    i = i + 1
  Loop
  
  重複処理 = strCheckName

End Function

動作の様子

受信トレイの下位の「分類1」フォルダにメールを移動すると、デスクトップにある「フォルダ名」というフォルダに「メールの受信日＋メール件名」のフォルダが作成され、そこにメール本体と添付資料が保存されます。

一度フォルダから出してもう一回入れると、ちゃんと通し番号が付与されて改めて保管されました。

また、添付資料も同じ名前のものがあっても、それぞれ保管されています。

（補足）全ての受信メールに処置していいなら、、、

今回は「メールを特定のフォルダに移動」をトリガーとして処理するため、Items_ItemAddイベント（特定のフォルダにアイテムが増えた時に起動）を使いました。
しかし、もし全ての受信メールに処置してOKであれば、「メールの受信時」のイベントである「Application_NewMailEx」を使えばOKです。

この場合、ThisOutlookSessionに記述するイベントマクロのコードは、たったこれだけになります。
（WithEventsでmy分類1Itemを定義したりApplication_Startupでの初期設定は全く不要です。）

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

  Call 添付保存(GetNamespace("MAPI").GetItemFromID(EntryIDCollection))

End Sub

解説

ちょっとこのコードは長いし難しいですね。
アプリケーションレベルではなくアイテムレベルのイベントなので、マジ難しいと思います。

イベントマクロの基本についてはこちらをご参照ください。

また、保存のコードは一発保存マクロを流用しました。こちらをご参照ください。

今回のコードのオリジナルの部分は次の部分です。

１． イベント用の「my分類1Items」を作成する

受信メールトレイ直下の「分類1」フォルダ内のItemsを示すmy分類1ItemsというオブジェクトをWithEventsステートメントで定義します。
WithEventsは「Dimと同じ」と思ってOKです。ただし、WithEventsで定義した変数はイベントに応答するようになります。

コードの先頭にあるの部分です。

'イベント用の「my分類1Item」を作成する
Private WithEvents my分類1Items As Items

２．Outlookの起動時に my分類1Item を「受信トレイ直下の分類1フォルダ内のItems」としてセットする

次のコードで、 my分類1Item を「受信トレイ直下の分類1フォルダ内のItems」 としてセットしています。
このコードを書かないと、 my分類1Item は「受信トレイ」「ゴミ箱」など、どのフォルダのItemsを指すのかがOutlookが認識できないため動作しません。

Private Sub Application_Startup()
'Outlook起動時に「my分類1Item」オブジェクトを受信トレイ直下の「分類1」フォルダとしてセットする

  Set my分類1Items = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("分類1").Items

End Sub

３．ItemAddイベント（アイテムが増えた時）をトリガーとし、メールが移動（保管）されたら、「添付保存」プロシージャを呼び出す。

次のイベントマクロで、メールが「分類1」フォルダに保管された時、「添付保存」マクロを起動します。

Private Sub myItem分類1Items_ItemAdd(ByVal Item As Object)
'受信トレイ直下の「分類1」フォルダにメールが追加された時に「添付保存」サブプロシージャを動作させる。
'なお、追加されたメールを表す引数「Item」を「添付保存」サブプロシージャに渡す
  
  Call 添付保存(Item)

End Sub

4．「添付保存」プロシージャで保存処理を行う

次のマクロで、メール本体および添付資料をフォルダに保存しています。
フォルダは受信日（Item.ReceivedTime）のyyyymmdd形式＋メール件名にしました。
あとはFSOを使ってフォルダを作り、その中に「メール件名.msg」としてメール本体を保存。
さらに添付資料たち（Item.Attachments)をForEach構文ですべて同じフォルダに保管しています。

Sub 添付保存(ByVal Item As Object)

'保存先アドレスを定数PATHに登録
Const PATH As String = "C:\Users\ユーザ名\Desktop\フォルダ名"

'フォルダ名はメール受信日yyyymmdd＋件名とする
  Dim strItemPath As String
  strItemPath = PATH & "\" & Format(Item.ReceivedTime, "yyyymmdd_") & Item.Subject
  
  strItemPath = 重複処理(strItemPath)

'フォルダを作ってメール本体を保存する
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strItemPath
  
  Item.SaveAs strItemPath & "\" & Item.Subject & ".msg"

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

  With Item
    For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
        Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then

            strFile = strItemPath & "\" & objAttachment.FileName
            strFile = 重複処理(strFile)
            objAttachment.SaveAsFile strFile

        End If
    Next objAttachment
  End With
  
  '各オブジェクト達をNothingで消しておく
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub

一見複雑に見えますが、実際に複雑なのは添付資料を保存するWith文の間だけです。
ここは埋め込み画像は添付資料として保管されないように例外処理をしているから複雑になっています。本体は「objAttachment.SaveAsFile strFile」の一文だけです。

5．重複処理について

4項の途中に「重複処理」というコードが出てきます。
これは、同じ名前のフォルダが２つできたり、同じ名前の添付資料が２つあった場合に通し番号を付けるという処理です。

例）test.txtが３つ添付されていた場合　⇒　test.txt、test(1).txt、test(2).txtとしてすべて保管

Function 重複処理(ByVal strName)

 '同名ファイル・フォルダがあれば通し番号を追加

  Dim strCheckName As String
  Dim i As Integer

  strCheckName = strName
  
  i = 1
    
  Do While Dir(strCheckName, vbDirectory) <> ""
    If InStr(strCheckName, ".") <> 0 Then
      strCheckName = Left(strName, InStrRev(strName, ".") - 1) & "(" & i & ")" & Mid(strName, InStrRev(strName, "."))
    Else
      strCheckName = strName & "(" & i & ")"
    End If
    i = i + 1
  Loop
  
  重複処理 = strCheckName

End Function

Dir関数を使って、ファイルとフォルダ名かぶりをチェックし、かぶっていたら通し番号を打つ処理を指せています。
アドレスに「.」が付けばファイル、「.」が付かなければフォルダ、として処理しています。ここはちょっとエラーが出そうなので、もっと改善の余地がありそうです。

ではまた別の記事で～
🦅バサバサ～

くのへスタジオはこちら。
Outlook-VBAコーナーはこちら。