Excel VBA가 전달 된 Outlook 전자 메일에 본문을 포함합니다.

Question

A 열에 제공된 제목을 기반으로 전자 메일을 루핑하여 전달하려고합니다. 그 작업은 완벽하지만 C 열의 내용을 해당 메일 각각에 포함시키고 싶습니다.

초기 메일에서 세부 정보를 삭제합니다.

요청 템플릿 아래 바와 같이

가

바디 콘텐트는 또한 열 값을 사용한다.

은 어떤 하나

Option Explicit 
Public Sub Example() 
Dim olApp As Outlook.Application 
Dim olNs As Outlook.Namespace 
Dim Inbox As Outlook.MAPIFolder 
Dim Item As Variant 
Dim MsgFwd As MailItem 
Dim Items As Outlook.Items 
Dim Email As String 
Dim Email1 As String 
Dim ItemSubject As String 
Dim lngCount As Long 
Dim i As Long 
Dim RecipTo As Recipient 
Dim RecipCC As Recipient 
Dim RecipBCC As Recipient 
Dim onbehalf As Variant 



Set olApp = CreateObject("Outlook.Application") 
Set olNs = olApp.GetNamespace("MAPI") 
Set Inbox = olNs.GetDefaultFolder(olFolderInbox) 
Set Items = Inbox.Items 

i = 2 ' i = Row 2 

With Worksheets("Sheet1") ' Sheet Name 
    Do Until IsEmpty(.Cells(i, 1)) 

    ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) 
    Email = .Cells(i, 16).Value '(i, 2) = (Row 2,Column 2) 
    Email1 = .Cells(i, 2).Value 

     '// Loop through Inbox Items backwards 
     For lngCount = Items.Count To 1 Step -1 
      Set Item = Items.Item(lngCount) 

      If Item.Subject = ItemSubject Then ' if Subject found then 
       Set MsgFwd = Item.Forward 
       Set RecipTo = MsgFwd.Recipients.Add(Email1) ' add To Recipient 
       Set RecipTo = MsgFwd.Recipients.Add("sen@aa.com") 
       Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient 
       MsgFwd.SentOnBehalfOfName = "doc@aa.com" 


        RecipTo.Type = olTo 
        RecipBCC.Type = olBCC 
        MsgFwd.Display 

      End If 
     Next ' exit loop 

     i = i + 1 ' = Row 2 + 1 = Row 3 
    Loop 
End With 

Set olApp = Nothing 
Set olNs = Nothing 
Set Inbox = Nothing 
Set Item = Nothing 
Set MsgFwd = Nothing 
Set Items = Nothing 

MsgBox "Mail sent" 
End Sub 

Answer 1

에 함께 Dim EmailBody As String 다음 문자열로 새로운 변수를 추가 열 C EmailBody = .Cells(i, 3).Value에 할당 .. 나를 제거하고 아래에서이 세부 사항을 포함 도울 수 귀하 Do Loop

간단하게 추가하여 Item.Forward 몸에서 다음 제거하려면 당신에 Item.Body 당신의 MsgFwd.Body - 그것은 Item.Body 만

---

MsgFwd.HTMLBody = EmailBody & "<BR>" & "<BR>" & Item.HTMLBody으로 전체 이메일 전달 본체를 교체해야합니다

---

다만 한 가지가 누락 .. 완벽하게 작동 0m3r @

예

Dim EmailBody As String 
With Worksheets("Sheet1") ' Sheet Name 
    Do Until IsEmpty(.Cells(i, 1)) 

    ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) 
    Email = .Cells(i, 16).Value '(i, 2) = (Row 2,Column 2) 
    Email1 = .Cells(i, 2).Value 
    EmailBody = .Cells(i, 3).Value 

     '// Loop through Inbox Items backwards 
     For lngCount = Items.Count To 1 Step -1 
      Set Item = Items.Item(lngCount) 

      If Item.Subject = ItemSubject Then ' if Subject found then 
       Set MsgFwd = Item.Forward 
       Set RecipTo = MsgFwd.Recipients.Add(Email1) ' add To Recipient 
       Set RecipTo = MsgFwd.Recipients.Add("sen@aa.com") 
       Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient 
       MsgFwd.SentOnBehalfOfName = "doc@aa.com" 

       RecipTo.Type = olTo 
       RecipBCC.Type = olBCC 

       Debug.Print Item.Body ' Immediate Window 

       MsgFwd.HTMLBody = EmailBody & "<BR>" & "<BR>" & Item.HTMLBody 
       MsgFwd.Display 

      End If 
     Next ' exit loop