将Outlook电子邮件内容下载到excel中

Question

我需要下载特定的所有电子邮件到excel。我发现了一个非常接近的代码，但邮件内容并未粘贴在单个单元格中。

而且我也想只有身体的特定细节。可有一个人帮我修改为下面的代码..

*更新：

我需要的邮件内容只是一部分（如下标）被下载到Excel。

能否请你帮我这个。

Excel的VBA代码：

Sub GetMail() 

Dim olApp As Object 
Dim olFolder As Object 
Dim olMailItem As Object 

Dim strTo As String 
Dim strFrom As String 
Dim dateSent As Variant 
Dim dateReceived As Variant 
Dim strSubject As String 
Dim spBody As Variant 

Dim loopControl As Variant 
Dim mailCount As Long 
Dim totalItems As Long 
'------------------------------------------------------------- 

'//Turn off screen updating 
Application.ScreenUpdating = False 

'//Setup headers for information 
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)") 

'//Format columns E and F to 
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS" 

'//Create instance of Outlook 
Set olApp = CreateObject("Outlook.Application") 

'//Select folder to extract mail from 
Set olFolder = olApp.GetNamespace("MAPI").PickFolder 

'//Get count of mail items 
totalItems = olFolder.Items.Count 
mailCount = 0 

'//Loop through mail items in folder 
For Each loopControl In olFolder.Items 

    '//If loopControl is a mail item then continue 
    If TypeName(loopControl) = "MailItem" Then 

     '//Increase mailCount 
     mailCount = mailCount + 1 

     '//Inform user of item count in status bar 
     Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems 

     '//Get mail item 
     Set olMailItem = loopControl 

     '//Get Details 
     With olMailItem 
      strTo = .To 
      '//If strTo begins with "=" then place an apostrophe in front to denote text format 
      If Left(strTo, 1) = "=" Then strTo = "'" & strTo 
      strFrom = .Sender 
      '//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe <[email protected]>) 
      If InStr(1, strFrom, "@") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >" 
      dateSent = .SentOn 
      dateReceived = .ReceivedTime 
      strSubject = .Subject 
      spBody = Split(.Body, vbCrLf) 
     End With 

     '//Place information into spreadsheet 
     '//import information starting from last blank row in column A 
     With Range("C" & Rows.Count).End(xlUp).Offset(1, -2) 
      .Value = strTo 
      .Offset(0, 1).Value = strFrom 
      .Offset(0, 2).Value = strSubject 
      .Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody) 
      .Offset(0, 4).Value = dateSent 
      .Offset(0, 5).Value = dateReceived 

     End With 

     '//Release item from memory 
     Set olMailItem = Nothing 

    End If 

    '//Next Item 
Next loopControl 

'//Release items from memory 
Set olFolder = Nothing 
Set olApp = Nothing 

'//Resume screen updating 
Application.ScreenUpdating = False 

'//reset status bar 
Application.StatusBar = False 

'//Inform user that code has finished 
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete" 

End Sub 

Answer 1

变化 “但邮件内容不会在一个单元格粘贴”：

Dim spBody As Variant 

到：

Dim spBody As String 

然后改变：

 spBody = Split(.body, vbCrLf) '<--| Split() function is "splitting" the mail body into an array with as many elements as vbCrlf occurrences plus one 

到：

 spBody = .body 

最后修改：

 .Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody) '<--| Resize() is "widening" the range to write values in to as many rows as 'spBody' array elements 

到：

 .Offset(0, 3).Value = spBody