将 Outlook 电子邮件导出到 Excel

Question

美好的一天！我是 VBA 新手。我正在尝试借助一些在线可用的 VBA 脚本自动将电子邮件从 Outlook 导出到 Excel。我最终得到了 80% 的结果。请查看我使用的代码。在那，我还需要添加一些代码来导出邮件正文。有人请指导我。

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 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

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


    strExcelFile = "d:\LocalData\Z018439\Desktop\MY\NX-AMO\Mail Export\export.xlsx"


    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")


    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1

    strColumnB = objMail.SenderName
    strColumnC = objMail.SenderEmailAddress
    strColumnD = objMail.Subject
    strColumnE = objMail.ReceivedTime


    If StrComp(strColumnB, "service_manager7@mail.nissan.co.jp", vbTextCompare) = 0 Then

    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.Columns("A:E").AutoFit


    objExcelWorkBook.Close SaveChanges:=True


    End If

    objExcelApp.Quit


    Set objExcelApp = Nothing


Set objExcelWorkBook = Nothing



  Set objExcelWorkSheet = Nothing



   Set objMail = Nothing

End Sub

Answer 1

身体和你想的一样。

strColumnF = objMail.Body

您还有objMail.HTMLBody（将显示带有html标签的正文）、CreationTime、FlagStatus、Recipients（收件人的集合，需要转换为字符串）等等。您可以通过查看 view>Locals Window 查看调试模式下任何表达式的所有属性的完整列表。

Answer 2

试试这个。

Sub Import_Outlook_to_Excel()
    Dim oitem As Outlook.MailItem
    Dim i As Long
    Sub all_folder_scan()
    'Tools Reference Microsoft Outlook
    Dim olapp As Outlook.Application
    Dim olappns As Outlook.Namespace
    Dim oinbox As Outlook.Folder
    Dim oFolder As Outlook.MAPIFolder
    i = 2 
    'tools->refrence->microsoft outlook
    Set olapp = New Outlook.Application
    Set olappns = olapp.GetNamespace("MAPI")
    ' set inbox folder
    Set oinbox = olappns.GetDefaultFolder(olFolderInbox)
        'For Each oitem In oinbox.Items.Restrict("[UnRead] = True")
            Sheets("All Folders Scan").Cells(i, 5).Value = oitem.Subject
            Sheets("All Folders Scan").Cells(i, 4).Value = oitem.SenderEmailAddress
            Sheets("All Folders Scan").Cells(i, 3).Value = oitem.SenderName
            Sheets("All Folders Scan").Cells(i, 6).Value = oitem.Body
            Sheets("All Folders Scan").Cells(i, 7).Value = oitem.ReceivedTime
            Sheets("All Folders Scan").Cells(i, 2).Value = oinbox.Name
            Sheets("All Folders Scan").Cells(i, 1).Value = oinbox.FolderPath
            i = i + 1
        'Next
        For Each oFolder In oinbox.Folders
            Call subfolders_go(oFolder)
        Next
    End Sub

    Private Sub subfolders_go(oParent As Outlook.Folder)
    Dim oFolder1 As Outlook.MAPIFolder
        For Each oitem In oParent.Items.Restrict("[UnRead] = True")
            Sheets("All Folders Scan").Cells(i, 5).Value = oitem.Subject
            Sheets("All Folders Scan").Cells(i, 4).Value = oitem.SenderEmailAddress
            Sheets("All Folders Scan").Cells(i, 3).Value = oitem.SenderName
            Sheets("All Folders Scan").Cells(i, 6).Value = oitem.Body  
            Sheets("All Folders Scan").Cells(i, 7).Value = oitem.ReceivedTime
            Sheets("All Folders Scan").Cells(i, 2).Value = oParent.Name 
            Sheets("All Folders Scan").Cells(i, 1).Value = oParent.FolderPath 
            i = i + 1   
        Next  
        If (oParent.Folders.Count > 0) Then
            For Each oFolder1 In oParent.Folders
                Call subfolders_go(oFolder1)
            Next
        End If 
    End Sub

Answer 3

应该有 objMail.cmets 或 objMail.body 的选项。然后可以将其导出到另一列吗？