エクセルVBA、Outlook2013から添付ファイルの付いたメールから、添付ファイルだけを抽出する場合

Question

エクセルのマクロ(VBA)で、Outlook2013の添付ファイルの付いたメールから、添付ファイルだけを抽出する場合

アカウントが1つだけの場合は、下記のコードでできるのですが、Outlook2013に複数アカウントが設定されている場合、下記のような状態で2番目のアカウントの受信フォルダの中のテスト01フォルダから抽出したい場合、下記画像のようなエラーメッセージが出て上手く抽出できません。

Outlook2013のスクリーンショット：

エラーメッセージ：

コード：

Sub メールから添付ファイル抽出()

Dim myNamespace As Namespace
Dim myInbox As Object
Dim mySubfolder As Object
Dim strPath As String
Dim strFile As String
Dim i As Long
 
Set myNamespace = GetNamespace("MAPI")
 
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set mySubfolder = myInbox.Folders.Item("テスト01") '受信トレイのすぐ下のフォルダ

strPath = "C:\Users\ET\Documents\MyDocument_BackUP\E_Excel\保存テスト01\" '添付ファイルを保存したいフォルダ

For Each objItem In mySubfolder.Items
    With objItem
    For i = 1 To .Attachments.Count
 
        strFile = strPath & .Attachments.Item(i)
    .Attachments.Item(i).SaveAsFile strFile
 
    Next i
    End With
Next objItem

MsgBox ("無事終了")

End Sub

エラーメッセージの通り、アカウントが1つの場合はフォルダを指定するだけで大丈夫だったのですが、複数となると、どのアカウントかを指定する、オブジェクトを指定する必要があると思うのですが、その方法がよくわかりません。

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)

たぶん、myInbox（受信トレイ）この行の前に、アカウントを指定するための、オブジェクトをSetするようなコードが入るのだと思うのですが、私が調べた限りではよくわかりませんでした。
皆さまの知恵をおかしください。

Answer 1

↓これ使えませんか?
複数アカウントが設定されているプロファイルのメイン以外のアカウントの予定表を取得する方法
※リンク先は予定表の取得ですが、
olFolderCalendar→olFolderInbox で採取できないでしょうか?

Answer 2

h.horikoshiさまに教えていただいたリンク先にあったコードを、オブジェクトのセット方法などを、少し置き換えて試したところ、手元のPCでは上手く動きました。
あとは会社のPCで動けば完全解決です。ありがとうございました。

Sub SaveAttachmentFiles()
Dim myNamespace As Namespace
Dim myInbox As Object
Dim mySubfolder As Object
Dim strPath As String
Dim strFile As String
Dim i As Long

Set myNamespace = GetNamespace("MAPI")

'---教えてもらったコードを追加した部分---
Dim objAcct As Account
Dim objStore As Store
Dim fldICalendar As Folder
' アカウントの取得 --- 先頭にGetNamespace("MAPI")で取得したオブジェクトをセット
Set objAcct = myNamespace.Application.Session.Accounts("[e-mail]")
' ストアの取得
Set objStore = objAcct.DeliveryStore
' 予定表の取得 --- olFolderCalendarを、olFolderInboxに置き換え
Set myInbox = objStore.GetDefaultFolder(olFolderInbox)
'---教えてもらったコードを追加した部分ここまで

Set mySubfolder = myInbox.Folders.Item("テスト01") '受信トレイ内のフォルダ

strPath = Range("A8").Value '添付ファイルを保存したいフォルダ

For Each objItem In mySubfolder.Items
    With objItem
    For i = 1 To .Attachments.Count
 
        strFile = strPath & .Attachments.Item(i)
    .Attachments.Item(i).SaveAsFile strFile
 
    Next i
    End With
Next objItem

MsgBox ("無事終了")

End Sub

Answer 3

ちゃんと調べていませんが、おそらく、アカウントは明示指定できなくて、現在アクティブなアカウントを見に行くのだと思います。

Comments

[kawase2]

＞現在アクティブなアカウント
というのが、よくわかりません。
送受信した直後のアカウントということでしょうか？
またはメールやフォルダが選択されている状態でしょうか？