导出传入 Outlook 电子邮件的“收件人”地址

Question

我一直在尝试将有关收到的电子邮件的详细信息导出到 Excel 电子表格。除了在“收件人”和“抄送”字段中返回收件人的显示名称外，该代码可以正常工作。
我尝试了几种变体。

我正在使用我在网上找到的以下代码：

Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
    Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)

    Dim objMail As Outlook.MailItem
    Dim Recipient As Outlook.Recipient
    Dim strExcelFile As String
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkBook As Excel.Workbook
    Dim objExcelWorkSheet As Excel.Worksheet
    Dim nNextEmptyRow As Integer
    Dim strColumnB As String
    Dim strColumnC As String
    Dim strColumnD As String
    Dim strColumnE As String
    Dim strColumnF As String
    Dim strColumnG As String

    If Item.Class = olMail Then
        Set objMail = Item
    End If
 
    'Specify the Excel file which you want to auto export the email list
    'You can change it as per your case
    strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"
 
    'Get Access to the Excel file
    On Error Resume Next
    Set objExcelApp = GetObject(, "Excel.Application")
    If Error <> 0 Then
        Set objExcelApp = CreateObject("Excel.Application")
    End If
    Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
    Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
 
    'Get the next empty row in the Excel worksheet
    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
 
    'Specify the corresponding values in the different columns
    strColumnB = objMail.SenderName
    strColumnC = objMail.SenderEmailAddress
    strColumnD = objMail.Subject
    strColumnE = objMail.ReceivedTime
    strColumnF = objMail.To
    strColumnG = objMail.CC
 
    'Add the vaules into the columns
    objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
    objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
    objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
    objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
    objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
    objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
    objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG
 
    'Fit the columns from A to G
    objExcelWorkSheet.Columns("A:G").AutoFit
 
    'Save the changes and close the Excel file
    objExcelWorkBook.Close SaveChanges:=True
End Sub

Answer 1

.Recipient 有一个 .Address 属性。

Recipient.Address 属性 (Outlook) https://docs.microsoft.com/en-us/office/vba/api/outlook.recipient.address

Option Explicit

Public WithEvents objMails As Items


Private Sub Application_Startup()
  Set objMails = Session.GetDefaultFolder(olFolderInbox).Items
End Sub


Private Sub objMails_ItemAdd(ByVal Item As Object)

    Dim objMail As MailItem
    Dim i As Long
    Dim recipAddresses As String
    
    If Item.Class = olMail Then
    
        Set objMail = Item
    
        For i = 1 To objMail.Recipients.Count
            recipAddresses = recipAddresses & objMail.Recipients(i).Address & " "
        Next
        
        Debug.Print Trim(recipAddresses)
        
    End If

End Sub


Private Sub test_objMails_ItemAdd()
    objMails_ItemAdd ActiveInspector.CurrentItem
End Sub

代码详解：

Option Explicit

Private Sub objMails_ItemAdd(ByVal Item As Object)
    
    Dim objMail As MailItem
    Dim recip As Recipient
    
    Dim recipAddressesTo As String
    Dim recipAddressesCC As String
    
    Dim i As Long
    
    Dim strExcelFile As String
    
    ' Early binding - Set reference to Excel XX.X Object Library
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkBook As Excel.Workbook
    Dim objExcelWorkSheet As Excel.Worksheet
    
    Dim nNextEmptyRow As Long
    
    If Item.Class = olMail Then
    
        Set objMail = Item
        
        'Specify the Excel file
        strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"
    
        'Get the Excel file
        
        ' Bypass normal error handling
        On Error Resume Next    ' To be used for a specific purpose
        
        Set objExcelApp = GetObject(, "Excel.Application")
        
        ' ?
        Debug.Print " Error: " & Error
        'If Error <> 0 Then
        
        Debug.Print " Err..: " & Err
        If Err <> 0 Then
            Set objExcelApp = CreateObject("Excel.Application")
        End If
        
        ' Return to normal error handling
        On Error GoTo 0     ' Consider mandatory after On Error Resume Next
        
        Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
        Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
        
        With objExcelWorkSheet
        
            'Get the next empty row in the Excel worksheet
            nNextEmptyRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        
            'Specify the corresponding values in the different columns
            .Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
            .Range("B" & nNextEmptyRow) = objMail.senderName
            .Range("C" & nNextEmptyRow) = objMail.SenderEmailAddress
            .Range("D" & nNextEmptyRow) = objMail.Subject
            .Range("E" & nNextEmptyRow) = objMail.ReceivedTime
    
            For i = 1 To objMail.Recipients.Count
            
                Set recip = objMail.Recipients(i)
                
                If recip.Type = olTo Then
                    recipAddressesTo = recipAddressesTo & recip.Address & " "
                ElseIf recip.Type = olCC Then
                    recipAddressesCC = recipAddressesCC & recip.Address & " "
                End If
                
            Next
            
            ' Trim the space character at the end
            objExcelWorkSheet.Range("F" & nNextEmptyRow) = Trim(recipAddressesTo)
            objExcelWorkSheet.Range("G" & nNextEmptyRow) = Trim(recipAddressesCC)
            
            'Fit the columns from A to G
            objExcelWorkSheet.Columns("A:G").AutoFit
        
        End With
        
        'Save the changes and close the Excel file
        objExcelWorkBook.Close SaveChanges:=True
    
    End If
    
End Sub

Answer 2

感谢 niton，我最终调整了代码并使用了以下内容。 我面临的新问题是试图让交换地址显示为常规电子邮件地址。

有什么提示吗？

Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
  Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)

Dim objMail As Outlook.MailItem
Dim Recipient As Outlook.Recipient
    Dim recipAddressesTo As String
    Dim recipAddressesCC As String
    Dim i As Long
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
Dim strColumnF As String
Dim strColumnG As String

If Item.Class = olMail Then
   Set objMail = Item
End If

'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"

'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")

'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
  
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = objMail.SenderName
objExcelWorkSheet.Range("C" & nNextEmptyRow) = objMail.SenderEmailAddress
objExcelWorkSheet.Range("D" & nNextEmptyRow) = objMail.Subject
objExcelWorkSheet.Range("E" & nNextEmptyRow) = objMail.ReceivedTime

 For i = 1 To objMail.Recipients.Count
            
Set recip = objMail.Recipients(i)
                
If recip.Type = olTo Then
recipAddressesTo = recipAddressesTo & recip.Address & " "
ElseIf recip.Type = olCC Then
recipAddressesCC = recipAddressesCC & recip.Address & " "
End If
                
Next
            
' Trim the space character at the end
objExcelWorkSheet.Range("F" & nNextEmptyRow) = Trim(recipAddressesTo)
objExcelWorkSheet.Range("G" & nNextEmptyRow) = Trim(recipAddressesCC)

'Fit the columns from A to G
objExcelWorkSheet.Columns("A:G").AutoFit

'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub