Загрузите адрес электронной почты Outlook в excel

Question

Мне нужно загрузить все электронные письма, в частности, в 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 <j.bloggs@mail.com>) 
      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