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