VBAでOutlookのサブフォルダをmsgファイルで出力する

Outlookの受信フォルダをmsgファイルで出力することはできたのですが
これを指定のサブフォルダで行う方法がわかりません

わかる方よろしくお願いします

Sub GetMailToFile()
' Outlookのメールで条件に一致するメールをファイル保存する
Dim ol As Object
Dim fileName As String
Const CON_OUTFOLDER = "出力先"

' 起動しているOutlookを取得
Set ol = GetObject(, "Outlook.Application")
If ol Is Nothing Then Exit Sub

' メール一覧取得
mailcnt = 0
For Each itms In ol.GetNamespace("MAPI").GetDefaultFolder(6).Items ' ここの6で受信トレイ指定
If itms.Class = 43 Then ' olMail:43
If InStr(itms.Body, "PC") > 0 Then
' ファイル名として使用できない文字を置換
fileName = itms.Subject
fileName = Replace(fileName, "\", "")
fileName = Replace(fileName, "/", "")
fileName = Replace(fileName, ":", "")
fileName = Replace(fileName, ";", "")
fileName = Replace(fileName, "*", "")
fileName = Replace(fileName, "?", "")
fileName = Replace(fileName, "<", "")
fileName = Replace(fileName, ">", "")
fileName = Replace(fileName, "|", "")
' メールを保存
itms.SaveAs CON_OUTFOLDER & fileName & ".msg", 3 ' olMSG:3
End If
End If
Next

Set ol = Nothing
End Sub

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/07/15 00:16

こんばんは、

デフォルトアカウント受信フォルダのサブフォルダで良いのでしょうか？

＞For Each itms In ol.GetNamespace("MAPI").GetDefaultFolder(6).Items
上記を変更
For Each itms In ol.GetNamespace("MAPI").GetDefaultFolder(6).Folders("サブフォルダ名").Items

受信フォルダと同じ階層の場合
（コメントブロックは、別アカウント内のフォルダを対象に設定する場合）

　　Dim fldr As Folder, TargetFolder As Folder
　　Dim oAccount As Account

'　　For Each oAccount In ol.Session.Accounts
　　　　For Each fldr In ol.GetNamespace("MAPI").Folders
'　　　　　　If fldr = "別アカウント名" Then
　　　　　　　　Set TargetFolder = fldr.Folders("フォルダ名")
　　　　　　　　Exit For
'　　　　　　End If
　　　　Next
'　　Next

　　For Each itms In TargetFolder.Items


こんな感じでどうでしょう。

この回答へのお礼

ありがとうございます！
無事、サブフォルダのみ出力することができました！

お礼日時：2020/07/15 13:27