我如何使用Outlook將電子郵件發送給Excel中的多個收件人VBA

Question

我試圖在Excel表單上設置幾個按鈕來向不同的人羣發送電子郵件。我在單獨的工作表上創建了多個單元格範圍，以列出單獨的電子郵件地址。例如，我想要「按鈕A」打開Outlook並將「工作表B：單元格D3-D6」中的電子郵件地址列表。然後，所有必須完成的操作都是在Outlook中點擊「發送」。

這是我的VBA代碼到目前爲止，但我不能得到它的工作。有人能告訴我我錯過了什麼或者錯了嗎？

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

您可以通過在範圍"D3:D6"每一個細胞都環和構造您To字符串。簡單地將它分配給一個變體將無法解決目的。 EmailTo如果您將範圍直接指定給它，它將成爲一個數組。你也可以這樣做，但是你必須通過數組來創建你的To字符串

這是你正在嘗試的嗎？ （久經考驗）

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