【VBA】Outlook受信メール取得

標準モジュール1

Option Explicit
Declare Function GetInputState Lib "USER32" () As Long

Sub Outlook_mail_list_subfolder()
   '''---コード1｜このコード内で使用する変数を宣言
    Dim InboxFolder, subfolder, i, n, k, attno, maxchar As Long
    Dim sender, mes, path1, findstr, foldername As String
    Dim outlookObj As Outlook.Application
    Dim myNameSpace, objmailItem As Object
    Dim fso As FileSystemObject
    foldername = Range("C1").Value
    findstr = Range("E1").Value
    maxchar = Range("G1").Value
    
    '''---コード2｜定義した変数に必要な項目をセット
    Set outlookObj = CreateObject("Outlook.Application")
    Set myNameSpace = outlookObj.GetNamespace("MAPI")
    Set InboxFolder = myNameSpace.GetDefaultFolder(olFolderInbox) '送信はOut
    Set subfolder = InboxFolder.Folders(foldername)
    n = 3

   '''---コード+1｜高速化ON
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

   '''---コード+2｜項目名
    'Range("A2").Value = "No."
    'Range("B2").Value = "受信日時"
    'Range("C2").Value = "件名(タイトル)"
    'Range("D2").Value = "送信者名"
    'Range("E2").Value = "内容(本文)"
    'Range("F2").Value = "添付ファイルパス"

    '''---コード3｜メールの添付ファイルを保管するフォルダを作成
    'mes = InputBox("メールの添付資料を保管用フォルダを新しく作成します。フォルダ名を入力してください")
    mes = "添付ファイル"
    path1 = ThisWorkbook.Path & "\" & mes
    Set fso = CreateObject("Scripting.FileSystemObject")

On Error GoTo ErrLabel
    fso.CreateFolder (path1)
ErrLabel:

    '''---コード4｜解析する受信メールの範囲を決める]
    'MsgBox subfolder.Items.Count
    Application.StatusBar = "抽出中"
    For i = 1 To subfolder.Items.Count
        If i Mod 50 = 0 Then
            Application.StatusBar = CStr(i) + "/" + CStr(subfolder.Items.Count)
            If GetInputState() Then DoEvents
        End If
        
        Set objmailItem = subfolder.Items(i)

        attno = objmailItem.Attachments.Count
        If attno > 0 Then
            For k = 1 To attno
                objmailItem.Attachments(k).SaveAsFile (path1 & "\" & objmailItem.Attachments(k).DisplayName)
                Cells(n, Range("E1").Column + k).Value = "file://" + path1 & "\" & objmailItem.Attachments(k).DisplayName
            Next
        Else
            Range("F" & n).Value = "なし"
        End If

        If Range("F" & n).Value <> "なし" Or InStr(objmailItem.Body, findstr) <> 0 Then
            '''---コード5｜受信メールの件数、受信日時、件名(タイトル)、送信者名、内容(本文)を取得
            Range("A" & n).Value = i
            Range("B" & n).Value = objmailItem.ReceivedTime
            Range("C" & n).Value = objmailItem.Subject
            Range("D" & n).Value = objmailItem.SenderName
            'Range("E" & n).Value = objmailItem.Body
            Range("E" & n).Value = Left(objmailItem.Body, maxchar)
    
            '''---コード6｜メールの添付ファイルを保管する

            n = n + 1
        End If
    Next

    '''---コード7｜セットした変数を解除
    Set outlookObj = Nothing
    Set myNameSpace = Nothing
    Set InboxFolder = Nothing

    
   '''---コード+3｜高速化OFF
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Application.StatusBar = False

    MsgBox "抽出完了"
End Sub

参考

エクセルVBAでOutlookの受信メールフォルダとサブフォルダ名を書き出す方法
OutlookのメールをExcelに取り込む - お仕事メモ
■T'sWare Access Tips #114 ～DoEventsをパフォーマンスを下げずに使う方法～
Word,Excel他：ハイパーリンクでフォルダを開くには－ 教えて！HELPDESK

---

Markdown で Local file link - Qiita