【VBA】Outlookのメールデータを抽出

Sub Mailデータ抽出()

Dim oApp As New Outlook.Application

Dim oNs As Outlook.Namespace
Set oNs = oApp.GetNamespace("MAPI")

'抽出するプロファイルとフォルダを定義する
Dim oF As Folder
Set oF = oNs.Folders("任意のプロファイル").Folders("任意のフォルダ")

'アイテムのセット
Dim mailLists As Items
Set mailLists = oF.Items

'ソートを受信時間で、昇順(true:降順　false:昇順)
mailLists.Sort "[ReceivedTime]", true

'取得するデータの種類、入力箇所、取得数(例:3件)
Dim i As Long
For i = 1 To 3
On Error Resume Next
Cells(i + 1, "A").Value = mailLists.Item(i).ReceivedTime
Cells(i + 1, "D").Value = mailLists.Item(i).SenderEmailAddress
Cells(i + 1, "E").Value = mailLists.Item(i).Subject
Cells(i + 1, "F").Value = mailLists.Item(i).Body
Next i

End Sub

---

特定のサブフォルダを指定する場合は、フォルダの定義を以下のように変更する。
Set oF = oNs.Folders("任意のプロファイル").Folders("任意のフォルダ").Folders("任意のサブフォルダ")

---

※連続して別のフォルダの情報を取得する場合は、「Next i」と「End Sub」の間に、下記を追記。

Set oF = oNs.Folders("任意のプロファイル").Folders("任意のフォルダ")

Set mailLists = oF.Items

mailLists.Sort "[ReceivedTime]", True

For i = 1 To 3
On Error Resume Next
Cells(i + 5, "A").Value = mailLists.Item(i).ReceivedTime
Cells(i + 5, "D").Value = mailLists.Item(i).SenderEmailAddress
Cells(i + 5, "E").Value = mailLists.Item(i).Subject
Cells(i + 5, "F").Value = mailLists.Item(i).Body
Next i

End Sub