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