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

编程问答 2022-08-15

问题描述

我一直试图将有关传入电子邮件的详细信息导出到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

我将不胜感激。

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

excelexceloutlook