Làm cách nào để sử dụng Outlook để gửi email cho nhiều người nhận trong Excel VBA

Question

Tôi đang cố gắng thiết lập một số nút trên biểu mẫu Excel để gửi email cho các nhóm người khác nhau. Tôi đã thực hiện một số phạm vi ô trên một trang tính riêng biệt để liệt kê các địa chỉ email riêng biệt. Ví dụ, tôi muốn "Nút A" để mở Outlook và đặt danh sách các địa chỉ email từ "Worksheet B: Cells D3-D6". Sau đó, tất cả những gì phải làm là nhấn "Gửi" trong Outlook.

Đây là mã VBA của tôi cho đến nay, nhưng tôi không thể làm cho nó hoạt động. Ai đó có thể cho tôi biết những gì tôi đang thiếu hoặc làm sai, xin vui lòng?

VB:

Sub Mail_workbook_Outlook_1() 
    'Working in 2000-2010 
    'This example send the last saved version of the Activeworkbook 
    Dim OutApp As Object 
    Dim OutMail As Object 

    EmailTo = Worksheets("Selections").Range("D3:D6") 

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
     .To = EmailTo 
     .CC = "person1@email.com;person2@email.com" 
     .BCC = "" 
     .Subject = "RMA #" & Worksheets("RMA").Range("E1") 
     .Body = "Attached to this email is RMA #" & Worksheets("RMA").Range("E1") & ". Please follow the instructions for your department included in this form." 
     .Attachments.Add ActiveWorkbook.FullName 
     'You can add other files also like this 
     '.Attachments.Add ("C:\test.txt") 

     .Display 
    End With 
    On Error Goto 0 

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 

Answer 1

Bạn cần phải lặp qua từng tế bào trong khoảng "D3:D6" và xây dựng To chuỗi của bạn. Đơn giản chỉ cần gán nó vào một biến thể sẽ không giải quyết được mục đích. EmailTo trở thành một mảng nếu bạn gán phạm vi trực tiếp cho nó. Bạn cũng có thể thực hiện điều này nhưng sau đó bạn sẽ phải lặp qua mảng để tạo ra To chuỗi

Đây có phải là những gì bạn đang cố gắng không? (thử và thử nghiệm)

Option Explicit 

Sub Mail_workbook_Outlook_1() 
    'Working in 2000-2010 
    'This example send the last saved version of the Activeworkbook 
    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim emailRng As Range, cl As Range 
    Dim sTo As String 

    Set emailRng = Worksheets("Selections").Range("D3:D6") 

    For Each cl In emailRng 
     sTo = sTo & ";" & cl.Value 
    Next 

    sTo = Mid(sTo, 2) 

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
     .To = sTo 
     .CC = "person1@email.com;person2@email.com" 
     .BCC = "" 
     .Subject = "RMA #" & Worksheets("RMA").Range("E1") 
     .Body = "Attached to this email is RMA #" & _ 
     Worksheets("RMA").Range("E1") & _ 
     ". Please follow the instructions for your department included in this form." 
     .Attachments.Add ActiveWorkbook.FullName 
     'You can add other files also like this 
     '.Attachments.Add ("C:\test.txt") 

     .Display 
    End With 
    On Error GoTo 0 

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 

Answer 2

ToAddress = "test@test.com" 
ToAddress1 = "test1@test.com" 
ToAddress2 = "test@test.com" 
MessageSubject = "It works!." 
Set ol = CreateObject("Outlook.Application") 
Set newMail = ol.CreateItem(olMailItem) 
newMail.Subject = MessageSubject 
newMail.RecipIents.Add(ToAddress) 
newMail.RecipIents.Add(ToAddress1) 
newMail.RecipIents.Add(ToAddress2) 
newMail.Send