VBScript通过邮件合并自动化Outlook电子邮件

Question

我正在寻找一个VBScript，它会自动地发送一封电子邮件给我在excel表格中使用邮件合并的联系人列表上的每个人。

任何帮助，将不胜感激，如果你需要更多的信息只是问:)

基本上，我有这样的代码

Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath) 
    Dim objOutlook As Outlook.Application 
    Dim objOutlookMsg As Outlook.MailItem 
    Dim objOutlookRecip As Outlook.Recipient 
    Dim objOutlookAttach As Outlook.Attachment 

    ' Create the Outlook session. 
    Set objOutlook = CreateObject("Outlook.Application") 

    ' Create the message. 
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem) 

    With objOutlookMsg 
     ' Add the To recipient(s) to the message. 
     Set objOutlookRecip = .Recipients.Add("Nancy Davolio") 
     objOutlookRecip.Type = olTo 

    ' Set the Subject, Body, and Importance of the message. 
    .Subject = "This is an Automation test with Microsoft Outlook" 
    .Body = "This is the body of the message." &vbCrLf & vbCrLf 
    .Importance = olImportanceHigh 'High importance 

    ' Resolve each Recipient's name. 
    For Each ObjOutlookRecip In .Recipients 
     objOutlookRecip.Resolve 
    Next 

    ' Should we display the message before sending? 
    If DisplayMsg Then 
     .Display 
    Else 
     .Save 
     .Send 
    End If 
    End With 
    Set objOutlook = Nothing 
End Sub 

但我需要它，而不是创建一个电子邮件，它使用邮件合并，电子邮件将被发送到存储在Excel表格中的每个人，问题是，我不知道如何做到这一点，所以任何帮助将是伟大的！

感谢

Answer 1

这将发送一个电子邮件到一个Excel文件中的每个人。在本例中，名称位于列A中，电子邮件地址位于列B中，主题位于列C中。在草稿文件夹中创建模板并将主题设置为“模板”。在模板电子邮件中，围绕要替换为另一个字段的任何字段使用{}。在这个例子中，{name}被替换为列A中的名称。将{image}标签插入图像所需的位置。我假设你需要相同的图像，因为它是一个公司的标志，所以你只需在SendMessage Sub中定义路径。这将添加图像作为附件，但没有简单的方法来解决这个问题，但它会嵌入到电子邮件的正文中。

set app = CreateObject("Excel.Application") 
Set wb = app.Workbooks.Open ("H:\Book1.xls") 
'skip header row. set to 1 if you 
'don't have a header row 
set sh = wb.Sheets("Sheet1") 
row = 2 
name = sh.Range("A" & row) 
email = sh.Range("B" & row) 
subject = sh.Range("C" & row) 
'image = sh.Range("D" & row) 
LastRow = sh.UsedRange.Rows.Count 
For r = row to LastRow 
    If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then 
     SendMessage email, name, subject, TRUE, _ 
     NULL, "H:\Scripts\Batch\pic.png", 80,680 
     row = row + 1 
     name = sh.Range("A" & row) 
     email = sh.Range("B" & row) 
     subject = sh.Range("C" & row) 
     'image = sh.Range("D" & row) 
    End if 
Next 
wb.close 
set wb = nothing 
set app = nothing 


Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth) 

    ' Create the Outlook session. 
    Set objOutlook = CreateObject("Outlook.Application") 

    template = FindTemplate() 

    ' Create the message. 
    Set objOutlookMsg = objOutlook.CreateItem(0) 

    With objOutlookMsg 
     ' Add the To recipient(s) to the message. 
     Set objOutlookRecip = .Recipients.Add(EmailAddress) 
     objOutlookRecip.resolve 
     objOutlookRecip.Type = 1 

    ' Set the Subject, Body, and Importance of the message. 
    .Subject = Subject 
    .bodyformat = 3 
    .Importance = 2 'High importance 
    body = Replace(template, "{name}", DisplayName) 

    if not isNull(ImagePath) then 
     if not ImagePath = "" then 
     .Attachments.add ImagePath 
     image = split(ImagePath,"\")(ubound(split(ImagePath,"\"))) 
     body = Replace(body, "{image}", "<img src='cid:" & image & _ 
     "'" & " height=" & ImageHeight &" width=" & ImageWidth & ">") 
     end if 
    else 
     body = Replace(body, "{image}", "") 
    end if 

    if not isNull(AttachMentPath) then 
     .Attachments.add AttachmentPath 
    end if 

    .HTMLBody = body 

    ' Should we display the message before sending? 
    If DisplayMsg Then 
     .Display 
    Else 
     .Save 
     .Send 
    End If 
    End With 
    Set objOutlook = Nothing 
End Sub 

Function FindTemplate() 
    Set OL = GetObject("", "Outlook.Application") 
    set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16) 
    Set oItems = Drafts.Items 

    For Each Draft In oItems 
     If Draft.subject = "Template" Then 
      FindTemplate = Draft.HTMLBody 
      Exit Function 
     End If 
    Next 
End Function