时间戳

首页 > 解决方案 > 从 VBA 发出 2 封不同的电子邮件

excel - 从 VBA 发出 2 封不同的电子邮件

问题描述

我正在尝试从 VBA 发送 2 封不同的电子邮件，当第二封电子邮件弹出时我被卡住了，因为收件人没有按要求填写。

我不太精通编码，但设法将以下代码放在一起；请参见下面的代码：

Sub Export_Mail()

Dim strFile As String
Dim OutApp As outlook.Application
Dim objOutlookMsg As outlook.MailItem
Dim objOutlookRecip As Recipient
Dim Recipients As Recipients

Dim strFile2 As String
Dim OutApp2 As outlook.Application
Dim objOutlookMsg2 As outlook.MailItem
Dim objOutlookRecip2 As Recipient
Dim Recipients2 As Recipients

Dim sDate

  sDate = Date

  Set OutApp = CreateObject("Outlook.Application")
  Set objOutlookMsg = OutApp.CreateItem(olMailItem)
  
  strFile = "C:\filepath\filename.xlsx" 'Directories to save and get attachments from; including filename
  strFile2 = "C:\filepath\filename2.xlsm"
  strBody = "<BODY style=font-size:10pt> Hello Customer team,<br><br>Greetings greetings<br>Attached file extract." & vbCrLf & vbCrLf
  strBody2 = "<BODY style=font-size:10pt> Hello Internal team,<br><br>Greetings greetings<br>Attached full file." & vbCrLf & vbCrLf

  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Filename:=strFile2 'Turn alerts off to overwrite both files always
    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy
    ActiveWorkbook.SaveAs Filename:=strFile
  Application.DisplayAlerts = True
    ActiveWorkbook.Close
       
  Set Recipients = objOutlookMsg.Recipients
  Set objOutlookRecip = Recipients.Add("cust1@example.com")
  objOutlookRecip.Type = 1                                                      ' Type 1 = To; Type 2 = CC
  Set objOutlookRecip = Recipients.Add("cust2@example.com")
  objOutlookRecip.Type = 1
  Set objOutlookRecip = Recipients.Add("cust3@example.com")
  objOutlookRecip.Type = 2
  Set objOutlookRecip = Recipients.Add("cust4@example.com")
  objOutlookRecip.Type = 2
  
  With objOutlookMsg
    '.SentOnBehalfOfName = "myemail@example.net"
    .Subject = "Email Subject " & sDate
    For Each objOutlookRecip In objOutlookMsg.Recipients     'Resolve each Recipient's name.
      objOutlookRecip.Resolve
    Next
    .Attachments.Add strFile
    .display
    .HTMLBody = strBody & .HTMLBody
  End With
  'objOutlookMsg.send
  'Set OutApp = Nothing
  
  'Application.Wait (Now + TimeValue("00:00:10"))
  
  Set OutApp2 = CreateObject("Outlook.Application")
  Set objOutlookMsg2 = OutApp.CreateItem(olMailItem)
  
  With objOutlookMsg2
    .Subject = "Internal email sibject" & sDate
    Set Recipients2 = objOutlookMsg.Recipients ' Type 1 = To; Type 2 = CC
    Set objOutlookRecip2 = Recipients2.Add("internal1@example.net")
    objOutlookRecip2.Type = 1
    Set objOutlookRecip = Recipients2.Add("internal2@example.net")
    objOutlookRecip2.Type = 1
    Set objOutlookRecip = Recipients2.Add("internal3@example.net")
    objOutlookRecip2.Type = 2
    For Each objOutlookRecip In objOutlookMsg.Recipients     'Resolve each Recipient's name.
      objOutlookRecip.Resolve
    Next
    .Attachments.Add strFile2
    .display
    .HTMLBody = strBody2 & .HTMLBody
  End With
End Sub

我为第二封电子邮件设置的收件人正在第一封电子邮件中填写。第二封电子邮件弹出没有收件人。有关如何解决此问题的任何指示都会有很大帮助。

标签： excelvbaemailautomationoutlook

解决方案

非常感谢蒂姆·威廉姆斯。

Se 更正的代码如下

 Set OutApp2 = CreateObject("Outlook.Application")
  Set objOutlookMsg2 = OutApp.CreateItem(olMailItem)
  
  With objOutlookMsg2
    .Subject = "Internal email subject" & sDate
    Set Recipients2 = objOutlookMsg2.Recipients ' Type 1 = To; Type 2 = CC
    Set objOutlookRecip2 = Recipients2.Add("internal1@example.net")
    objOutlookRecip2.Type = 1
    Set objOutlookRecip2 = Recipients2.Add("internal2@example.net")
    objOutlookRecip2.Type = 1
    Set objOutlookRecip2 = Recipients2.Add("internal3@example.net")
    objOutlookRecip2.Type = 2
    For Each objOutlookRecip2 In objOutlookMsg2.Recipients     'Resolve each Recipient's name.
      objOutlookRecip2.Resolve
    Next
    .Attachments.Add strFile2
    .display
    .HTMLBody = strBody2 & .HTMLBody
  End With
End Sub

推荐阅读