VBAでアカウントを指定してメールを保存したいです

Question

前提・実現したいこと

VBA初心者です。
エクセルVBAにて受信トレイのの"TEST"フォルダからメールと添付ファイルを取り出しエクセルと同階層の指定したフォルダに格納するというものを作成しました。
※シートにメール本文を記載するというものも混ざっていました。

これをもとに、アカウントを指定してメール、添付ファイルを取り出すというものを作成しようとしましたが、どうもうまくいきません。
（もともとのアカウントが"〇〇@outlook.jp"だとして、
"[e-mail]"や"[e-mail]"などでも取り出せるようにしたいです。）

追記

アカウントで指定してそのアカウントのメールの添付ファイルを保存できるようにしたいです。
エクセルのA1セルにメールアドレスを設定してそのアカウントの受信フォルダから添付ファイルがあるものを取得するイメージ。

該当のソースコード

Sub 保存()
    Dim i, j As Long                                                        ' 変数設定：カウンタ用変数
    Dim latestRow, rowNum As Long                                           ' 変数設定：シートの一番下の行の位置、現在のメール件数(A列表示用)
    Dim mailFolder, attno As Long                                           ' 変数設定：受信トレイ、添付ファイルの数
    Dim sender, mes, strtmp As String                                       ' 変数設定：受信トレイ内の総メール件数メッセージ、文字列変換用変数
    Dim path1, path2 As String                                              ' 変数設定：パス指定用変数
    Dim objOutlook As Outlook.Application                                   ' Outlookで使用するオブジェクト生成
    Dim myNameSpace, objmailItem As Object                                  ' Outlookで使用するオブジェクト(2つ)生成
    Dim folder As FileSystemObject                                          ' フォルダ生成で使用するオブジェクト
    
    Set objOutlook = CreateObject("Outlook.Application")                    ' 受信メールを解析するシート名を「受信メール一覧」で設定
    Set myNameSpace = objOutlook.GetNamespace("MAPI")                       ' outlookのメールを解析
    Set mailFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("TEST")        ' 受信トレイを指す
    Debug.Print mailFolder
    
    path1 = ThisWorkbook.Path & "\保存用"                                   ' エクセルファイルと同じ階層にある「保存用」フォルダのパスを設定
    path2 = ThisWorkbook.Path & "\メール保存\"
    
    MsgBox mailFolder.Items.Count & "件実行しました。"                      ' 現在、受信トレイに保管されているメールが何通あるかメッセージを出す
    For i = 1 To mailFolder.Items.Count                                     ' i=(受信トレイ内の総メール件数)を順次セット
        Set objmailItem = mailFolder.Items(i)                               ' objmailItemに受信トレイのi通目のメールをセット
        
        With ThisWorkbook.Worksheets("メール受信情報")
            rowNum = .Cells(Rows.Count, 1).End(xlUp).Row                    ' A列の件数番号を取得
            latestRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1             ' 受信メールの情報をExcelの最後のデータの次から書き込む
            .Range("A" & latestRow).Value = rowNum                          ' セルA列latestRow(1,2,3,…)行目に、何通目のメールを解析しているかカウントする
            .Range("B" & latestRow).Value = objmailItem.ReceivedTime        ' セルB列latestRow(1,2,3,…)行目に、解析したメールの受信日時を出力
            .Range("C" & latestRow).Value = objmailItem.Subject             ' セルC列latestRow(1,2,3,…)行目に、解析したメールの件名(タイトル)を出力
            .Range("D" & latestRow).Value = objmailItem.SenderName          ' セルD列latestRow(1,2,3,…)行目に、解析したメールの送信者名を出力
            .Range("E" & latestRow).Value = objmailItem.SenderEmailAddress  ' セルE列latestRow(1,2,3,…)行目に、解析したメールの送信元のメールアドレスを出力
            .Range("F" & latestRow).Value = Left(objmailItem.Body, 100)     ' セルF列latestRow(1,2,3,…)行目に、解析したメールの内容(本文100文字まで)を出力

        attno = objmailItem.Attachments.Count                               ' attno=解析しているメールの添付ファイル数
            If attno > 0 Then                                               ' もし、解析しているメールに添付ファイル数が0より大きいならば(1つ以上あるなら)
                For j = 1 To attno                                          ' for next文で一つずつ、添付ファイルをフォルダへ保管する
                    
                    objmailItem.Attachments(j).SaveAsFile (path1 & "\" & .Range("D" & latestRow) _
                            .Value & "(" & j & ")_" & objmailItem.Attachments(j).DisplayName)         'Excelのセル_添付ファイル名
                Next
                ThisWorkbook.Worksheets("メール受信情報").Range("G" & latestRow).Value = attno        ' セルG列にメールに含まれる添付ファイル数を出力
            Else:                                                                                     ' もし､メールに添付ファイル数がないなら
                ThisWorkbook.Worksheets("メール受信情報").Range("G" & latestRow).Value = "なし"       ' セルG列に、「なし」と出力。
            End If                                                                                    ' End If でif文終了
        
            strtmp = .Range("C" & latestRow).Value & "(" & i & ")"                                    ' ファイル名(メール件名(i).msg)
            
            strtmp = Replace(strtmp, " ", "")                                                         ' 空白除去
            strtmp = Replace(strtmp, ":", "：")                                                       ' :を全角に
            strtmp = Replace(strtmp, "\", "￥")                                                       ' \を全角に
            strtmp = Replace(strtmp, "/", "")                                                         ' /を除去
            
            objmailItem.SaveAs path2 & strtmp & ".msg", olMSGUnicode                                  ' パスの指定先にメールを保存
        
        End With
    Next
    Set objOutlook = Nothing
    Set myNameSpace = Nothing
    Set mailFolder = Nothing
    
End Sub

試したこと

Accountを使うのかと思いましたが使い方が待ったうわからず、、、

Answer 1

outlookってアカウントに関係なくpstファイルにメールぶち込むイメージなんだけど
outlook側の設定で"[e-mail]"や"[e-mail]"のアカウントのメールも
TESTフォルダーに入るようにすればそのままで動くのでは？やったことないので予想ですが。

追記

わからんけどドキュメント読む限りでは
Application.session.Accounts(アカウント名).DeliveryStore

でそのアカウントのNameSpaceStoreにアクセスできるっぽい

    Set objOutlook = CreateObject("Outlook.Application")
    ' これだと既定のアカウントをとるらしい
    'Set myNameSpace = objOutlook.GetNamespace("MAPI") 
    ' アカウントを明示的に指定？
    Dim objStore As Outlook.Store
    Set objStore = objOutlook.session.Accounts("アカウント名").DeliveryStore
    ' 以下は同じ、GetDefaultFolderで受信メールフォルダを、Foldersでフォルダ指定してメールを回す
    Set mailFolder = objStore.GetDefaultFolder(olFolderInbox).Folders("TEST")

あとはアカウントの数とフォルダの数分だけやればよさげ。

Comments

[退会済みユーザー]

ご回答ありがとうございます。

sousuke様からいただいたものをもとに書き換えてみましたが、

Set objStore = objOutlook.session.Accounts("アカウント名").DeliveryStore

ここで既定以外のアカウントをいれると以下エラーが出てしまいます。
実行時エラー'91':
オブジェクト変数またはWithブロック変数が指定されておりません。

申し訳ないです、、、

[sousuke]

あ、気づいてなかったすみません。解決できました？
set accounts = objOutlook.session.Accounts とかやって中身見てアカウント名把握すればいいと思います。m(__)m

[退会済みユーザー]

はい！解決いたしました。
遅くなってしまい申し訳ございませんでした、、

[sousuke]

いえ良かったです。最初エラーが出ていたというのはアカウント名の間違いだったんですか？

[退会済みユーザー]

そうみたいでした
もう一度かきなおしたらうまくいきました