【VBA】Outlookの指定フォルダ内のメール要素を取得する

エクセルVBAでよく使うコードの備忘録。Outlookのメールを振り分けているフォルダ内のメールを取得するコード。メールを検索して要素を取得するなどする際に、検索するフォルダを指定するのに使ったりします。

事前準備

VBAでOutlookを操作するには、参照設定が必要です。VBAのコードエディタから「ツール > 参照設定」と進み、「Microsoft Outlook XX.X Object Library」にチェックを入れておきます。

指定フォルダを取得する関数

指定フォルダ内のメール要素を取得するために、まずは指定フォルダを取得する必要があります。受信トレイなどのデフォルト要素の取得は簡単ですが、自分で作成したフォルダを名前からしてできる関数を作成します。同じなまえが複数あることは考慮していません。

'--- フォルダオブジェクト内から指定した名前のフォルダを取得 ---'
Private Function getOutlookFolder(olFolder As Variant, folderName As String) As Variant
    Dim retFolder As Variant　'戻り値を格納する変数
    Dim i As Long
    Dim objFolderTmp As Variant
    
　　'フォルダオブジェクト（olFolder）の名前が指定した名前と違うときは子フォルダを検索
    If (olFolder.Name <> folderName Or olFolder.Folders.Count <> 0) Then
        For i = 1 To olFolder.Folders.Count
            Set objFolderTmp = olFolder.Folders(i)
            
            If (objFolderTmp.Name <> folderName) Then
                If (IsEmpty(getOutlookFolder(objFolderTmp, folderName))) Then
                    retFolder = Empty
                Else
                    Set retFolder = getOutlookFolder(objFolderTmp, folderName)
                End If
                
                If (Not IsEmpty(retFolder)) Then
                    Exit For
                End If
            Else
                If (objFolderTmp.Folders.Count = 0) Then
                    Set retFolder = objFolderTmp
                    Exit For
                Else
                    Set retFolder = getOutlookFolder(objFolderTmp, folderName)
                End If
                
            End If
        Next i
    Else
        Set retFolder = olFolder
    End If
    
    If (IsEmpty(retFolder)) Then
        getOutlookFolder = Empty
    Else
        Set getOutlookFolder = retFolder
    End If
End Function

フォルダ内のメール内容をワークシートに書き出す

指定した名前のフォルダ内にあるメールの内容をすべてワークシートに書き出します。

'--- 参照設定が使える場合 ---'
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
    
Dim objNS As Outlook.Namespace
Set objNS = objOutlook.GetNamespace("MAPI")
    
'--- 検索フォルダを指定 ---'
Dim objTargetFolder As Variant
Dim folderName As String
folderName = "[検索フォルダ名]"
    
Dim i As Long
Dim j As Long

'--- フォルダを取得 ---'
Dim objBox As Variant
For i = 1 To objNS.Folders.Count
    Set objBox = objNS.Folders(i)
    If (IsEmpty(getOutlookFolder(objBox, folderName))) Then
        objTargetFolder = Empty
    Else
        Set objTargetFolder = getOutlookFolder(objBox, folderName)
    End If
Next i

'--- フォルダが存在する場合は要素を取得しワークシートに書き出す ---'
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("[書き出し先のワークシート名]")

If (Not IsEmpty(objTargetFolder)) Then
    For i = 1 To objTargetFolder.Items.Count
        ws.Cells(i, 1).Value = objTargetFolder.Items(i).SentOn
        ws.Cells(i, 2).Value = objTargetFolder.Items(i).To
        ws.Cells(i, 3).Value = objTargetFolder.Items(i).Subject
        ws.Cells(i, 4).Value = objTargetFolder.Items(i).Body
            
        atcN = objTargetFolder.Items(i).Attachments.Count
        For j = 1 To atcN
            ws.Cells(i + cnt, 4 + j).Value = objTargetFolder.Items(i).Attachments(j).Filename
        Next j
    Next i
End If