从Excel文件发送多个收件人的Outlook电子邮件
我目前正在做一个VBAmacros，将发送一个单一的Outlook电子邮件，具有以下标准：
答：收件人被列在Sheet1的D列中，我想要的是将每个发件人连接到Outlook的TO字段。 但是，这些收件人是dynamic的，可能在数量上有所不同。 案例可能会导致从这些列中增加或减less电子邮件地址。
B.我需要将任何Sheet2的内容粘贴到Outlook的BODY字段中。 C.我需要生成带有签名的电子邮件。
到目前为止，我有这个代码，但它不工作：
Option Explicit Sub SendEmail() Dim OutlookApplication As Outlook.Application Dim OutlookMailItem As Outlook.MailItem Dim outlookInspector As Outlook.Inspector Dim wdDoc As Word.Document Dim Recipient As Range Dim CC As Range Application.ScreenUpdating = False Set OutlookApplication = New Outlook.Application Set OutlookMailItem = OutlookApplication.CreateItem(0) 'On Error GoTo cleanup Workbooks("ConfigFile.xlsm").Sheets("Sheet1").Activate Range("D2").Select Set Recipient = Range(ActiveCell, ActiveCell.End(xlDown)) Range("E2").Select Set CC = Range(ActiveCell, ActiveCell.End(xlDown)) With OutlookMailItem .Display .To = Recipient .CC = CC .subject = ThisWorkbook.Sheets("Sheet1").Range("F2").Value .Body = ThisWorkbook.Sheets("Sheet1").Range("G2").Value Set outlookInspector = .GetInspector Set wdDoc = outlookInspector.WordEditor wdDoc.Range.InsertBreak Sheet2.Activate Range("A:A").CurrentRegion.Copy wdDoc.Range.Paste End With 'cleanup: 'Set OutlookApplication = Nothing 'Application.ScreenUpdating = True End Sub 要回答问题的第一部分，请将.To和.CCreplace为：
Dim myDelegate As Outlook.Recipient For Each sTo In Recipient Set myDelegate = OutlookMailItem.Recipients.Add(sTo) myDelegate.Resolve If Not myDelegate.Resolved Then myDelegate.Delete End If Next sTo For Each sTo In CC Set myDelegate = OutlookMailItem.Recipients.Add(sTo) myDelegate.Type = olCC myDelegate.Resolve If Not myDelegate.Resolved Then myDelegate.Delete End If Next sTo
这将遍历D＆E列中的每个人，并将其input到相关字段中，如果某人不存在，则会删除该人，如果不希望发生这种情况，只需删除If语句在上面的每个循环中
其他两个问题应该单独询问，但Google快速search发现类似的问题，可以帮助你
用于将数据从Excel粘贴到Outlook Body
用于电子邮件签名
我用.To ＆ .CC来回答你的问题，你可能想看看他们，他们可能会在未来帮助你
我通过将所有这些分离的收件人添加到一个string来解决这个问题。 逐个获取它们并将它们添加到string中，并提供“;” 需要的地方:)
不知道它是否适用于一个范围..我认为这是问题所在。
希望能帮助到你！