Outlookの電子メールコンテンツをExcelにダウンロード

Question

私はすべての電子メールを特別にダウンロードして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