将部分电子邮件正文从 Outlook 提取到 Excel答案

【问题标题】：Extract partail email body from Outlook to Excel将部分电子邮件正文从 Outlook 提取到 Excel
【发布时间】：2016-02-25 01:55:37
【问题描述】：

您好，我正在尝试提取电子邮件正文的特定部分，并计算我收到的具有相同部分的电子邮件的数量。我正在使用以下 vba 代码，但遇到以下问题：

输出未填充，但脚本运行正常。
无法从电子邮件正文中提取该特定部分。

我使用的代码是：

Option Explicit
Sub Download_Outlook_Mail_To_Excel()
Dim Folder          As Outlook.MAPIFolder
Dim sFolders        As Outlook.MAPIFolder
Dim iRow            As Integer
Dim oRow            As Integer
Dim MailBoxName     As String
Dim Pst_Folder_Name As String

Const xlWorkbookName As String = "C:\Personal\Documents\Failures.xlsx" '// change as required

'// I'm using late binding in case you don't actually have a reference set.
Dim xlApp           As Object
Dim xlWB            As Object

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

Set xlWB = xlApp.Workbooks.Open(xlWorkbookName)

MailBoxName = "ridutta@gmail.com"


Pst_Folder_Name = "SR Creation Failure" 'Sample "Inbox" or "Sent Items"

'To directly a Folder at a high level
'Set Folder =  Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
    If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
    For Each sFolders In Folder.Folders
        If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
            Set Folder = sFolders
            GoTo Label_Folder_Found
        End If
    Next sFolders
Next Folder

Label_Folder_Found:
If Folder.Name = "" Then
    MsgBox "Invalid Data in Input"
    GoTo End_Lbl1:
End If

'Read Through each Mail and export the details to Excel for Email Archival
xlWB.Sheets(1).Activate
Folder.Items.Sort "Received"

'Insert Column Headers
xlWB.Sheets(1).Cells(1, 1) = "Sender"
xlWB.Sheets(1).Cells(1, 2) = "Subject"
xlWB.Sheets(1).Cells(1, 3) = "Date"
xlWB.Sheets(1).Cells(1, 4) = "Size"
xlWB.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
    'If condition to import mails received in last 60 days
    'To import all emails, comment or remove this IF condition
   If VBA.DateValue(VBA.Now) -  VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
       oRow = oRow + 1
       xlWB.Sheets(1).Cells(oRow, 1).Select
       xlWB.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
       xlWB.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
       xlWB.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
       xlWB.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
       xlWB.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
       'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
    End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

xlWB.Close False
Set xlWB = Nothing

xlApp.Quit
Set xlApp = Nothing

End_Lbl1:
End Sub

【问题讨论】：

将 xlWB.Close False 替换为 xlWB.Close True。如果这是答案，请考虑删除问题。

标签： vba excel email outlook

【解决方案1】：

使用正则表达式提取您要查找的电子邮件正文部分。参考这个：How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops

【讨论】：