受信トレイ内のメール一覧をExcelに出力

フォルダ指定のところとかもうちょっとやりようがありそう。
というか、Outlookの環境設定次第でいろいろ変わりそう。

追記:Exchangeユーザのメールアドレス取得がうまくできなかったので
http://www.gregthatcher.com/Scripts/VBA/Outlook/GetSmtpAddress.aspx
を参考に(というか、ほぼマルパクリ)修正しました。

Public Sub Test_ControlOutlook()

  Dim ol As Outlook.Application
  Dim olns As Outlook.Namespace
  Dim mFolder As Outlook.Folder
  Dim i As Long
  Dim j As Long
  Application.ScreenUpdating = False
  With ThisWorkbook.Worksheets(1)
    If .Range("A1").SpecialCells(xlLastCell).Row > 1 Then .Range(.Range("A2"), .Range("A2").SpecialCells(xlLastCell)).ClearContents
  End With
  
  Set ol = GetObject(, "Outlook.application")
  Set olns = ol.GetNamespace("MAPI")
  
  
  Set mFolder = olns.Folders(olns.Accounts.Item(1).DisplayName).Folders(ThisWorkbook.Worksheets(1).Range("D1").Value)
  j = 2
  For i = 1 To mFolder.Items.Count
    If mFolder.Items(i).Class = 43 Then
      With mFolder.Items(i)
'        If Left(.SenderEmailAddress, 1) = "/" Then Stop
        
        ThisWorkbook.Worksheets(1).Range("A" & j) = .ReceivedTime
        ThisWorkbook.Worksheets(1).Range("B" & j) = .Subject
          ThisWorkbook.Worksheets(1).Range("C" & j) = GetSmtpAddress(mFolder.Items(i), ol)
        ThisWorkbook.Worksheets(1).Range("D" & j) = .SenderEmailType
        j = j + 1
      End With
    End If
'    DoEvents
    Debug.Print Now(), i
    If i > 100 Then
      Application.ScreenUpdating = True
      MsgBox "メール件数が100件を超えたので処理を中断します。"
      Exit Sub
    End If
  Next i
  
  Application.ScreenUpdating = True
  
  MsgBox "受信トレイ内のメール一覧を作成しました!"

End Sub
  
Public Function GetSmtpAddress(mail As MailItem, ol As Outlook.Application) As String
'    On Error GoTo On_Error
    
    GetSmtpAddress = ""
    
    Dim Report As String
    Dim Session As Outlook.Namespace
    Set Session = ol.Session
    
    If mail.SenderEmailType <> "EX" Then
        GetSmtpAddress = mail.SenderEmailAddress
    Else
        Dim senderEntryID As String
        Dim sender As AddressEntry
        Dim PR_SENT_REPRESENTING_ENTRYID As String
        
        PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
        
        senderEntryID = mail.PropertyAccessor.BinaryToString( _
            mail.PropertyAccessor.GetProperty( _
                PR_SENT_REPRESENTING_ENTRYID))
        
        Set sender = Session.GetAddressEntryFromID(senderEntryID)
        If sender Is Nothing Or sender = "" Or IsNull(sender) Or IsEmpty(sender) Then
            GetSmtpAddress = "【削除済ユーザ】"
            Exit Function
        End If
        
        If sender.AddressEntryUserType = olExchangeUserAddressEntry Or _
            sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
                
            Dim exchangeUser As exchangeUser
            Set exchangeUser = sender.GetExchangeUser()
            
            If exchangeUser Is Nothing Then
              GetSmtpAddress = "【削除済ユーザ】"
                Exit Function
            End If
            
            GetSmtpAddress = exchangeUser.PrimarySmtpAddress
            Exit Function
        Else
            Dim PR_SMTP_ADDRESS
            PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
            GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
    End If
Exiting:
        Exit Function
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
    
End Function