Option Explicit
Sub Get_OutlookData()
Dim OLApp As Outlook.Application
Dim OLNamespace As Outlook.Namespace
Dim OLFolder As Outlook.MAPIFolder
Dim OLConItems As Outlook.Items
Dim OLItem As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim cntRow As Long
Dim startDate As Date
Dim endDate As Date
'行指定'
cntRow = 2
'抽出期間'
startDate = Format("2021/10/01", "yyyy/mm/dd") '開始日'
endDate = Format("2021/10/20", "yyyy/mm/dd") '終了日'
Application.ScreenUpdating = False
'出力先シートをクリア'
Worksheets("出力用").Cells.Clear
Set WB = ThisWorkbook
Set WS = WB.Worksheets("出力用")
'「出力用」シートにフィールド名を生成（1行目）'
With WS
.Cells.ClearContents
.Cells(1, 1).Value = "To"
.Cells(1, 2).Value = "CC"
.Cells(1, 3).Value = "BCC"
.Cells(1, 4).Value = "受信日時"
.Cells(1, 5).Value = "タイトル"
.Cells(1, 6).Value = "本文"
.Cells(1, 7).Value = "送信者"
.Cells(1, 8).Value = "送信者アドレス"
.Cells(1, 9).Value = "送信日時"
.Cells(1, 10).Value = "受信者名"
End With
WS.Activate
Set OLApp = New Outlook.Application
Set OLNamespace = OLApp.GetNamespace("MAPI")
'(1)'
'既定ユーザーの「受信トレイ」を対象に取得。デフォルトフォルダーで取得できます。'
'Set OLFolder = OLNamespace.GetDefaultFolder(olFolderInbox)'
'受信トレイの場合'
'個別に作成した特定のフォルダを指定したい場合。階層を上から指定する必要があります'
'以下の場合は「Outlook」配下の「受信トレイ」にさらに作成した「01●●」フォルダー内のメールのみ検索します。'
Set OLFolder = OLNamespace.Folders("Outlook").Folders("受信トレイ").Folders("01●●")
Set OLConItems = OLFolder.Items
'②Restrictメソッドで期間を絞り込む'
Set OLConItems = OLConItems.Restrict("[ReceivedTime] >= '" & startDate & "' And [ReceivedTime] <= '" & endDate & "'")
For Each OLItem In OLConItems
With OLItem
'①本文に「Yahoo」が含まれているもののみ抽出'
If InStr(.Body, "Yahoo") = 0 Then
Else
If TypeName(OLItem) = "MailItem" Then
Cells(cntRow, 1).Value = .To
Cells(cntRow, 2).Value = .CC
Cells(cntRow, 3).Value = .BCC
Cells(cntRow, 4).Value = .ReceivedTime
Cells(cntRow, 5).Value = .Subject
Cells(cntRow, 6).Value = .Body
Cells(cntRow, 7).Value = .SenderName
Cells(cntRow, 8).Value = .SenderEmailAddress
Cells(cntRow, 9).Value = .SentOn
Cells(cntRow, 10).Value = .ReceivedByName
cntRow = cntRow + 1
End If
End If
End With
Next OLItem
Set OLItem = Nothing
Set OLConItems = Nothing
Set OLFolder = Nothing
Set OLNamespace = Nothing
Set OLApp = Nothing
Application.ScreenUpdating = True
MsgBox "完了", vbInformation
End Sub
