从 VBA 发送 2 封不同的电子邮件
Firing 2 different emails from VBA
我正在尝试从 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
我为第二封电子邮件设置的收件人正在第一封电子邮件中填写。
第二封电子邮件弹出时没有收件人。
关于如何解决此问题的任何指示都会有很大帮助。
非常感谢蒂姆·威廉姆斯。
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
无需遍历所有收件人即可根据地址簿解析他们的姓名。 Recipients.ResolveAll 方法尝试根据地址簿解析 Recipients 集合中的所有 Recipient 对象。
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
.Recipients.ResolveAll
.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 = .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
Recipients2.ResolveAll
.Attachments.Add strFile2
.display
.HTMLBody = strBody2 & .HTMLBody
End With
End Sub
我正在尝试从 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
我为第二封电子邮件设置的收件人正在第一封电子邮件中填写。 第二封电子邮件弹出时没有收件人。 关于如何解决此问题的任何指示都会有很大帮助。
非常感谢蒂姆·威廉姆斯。
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
无需遍历所有收件人即可根据地址簿解析他们的姓名。 Recipients.ResolveAll 方法尝试根据地址簿解析 Recipients 集合中的所有 Recipient 对象。
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
.Recipients.ResolveAll
.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 = .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
Recipients2.ResolveAll
.Attachments.Add strFile2
.display
.HTMLBody = strBody2 & .HTMLBody
End With
End Sub