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

身体就像你想的那样。

origTbl

您还有strColumnF = objMail.Body（将显示带有html标签的正文），objMail.HTMLBody，CreationTime，FlagStatus（收件人的集合，需要转换）到一个字符串），等等。通过查看视图＆gt; 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.comments或objMail.body应该有一个选项。然后，您可以将其导出到另一列？

将Outlook电子邮件导出到Excel

3 个答案: