我有一个像这样的工作簿:
Column B Column Q
C:\Folder\file1.xls Recipient1@email.com
C:\Folder\file2.xls Recipient2@email.com
C:\Folder\file3.xls Recipient3@email.com
我想在Q栏中向每位收件人发送电子邮件。 我不想向多个收件人发送一封电子邮件,而是希望在列表中为每个收件人发送一封电子邮件。
电子邮件主题,正文等每次都是相同的,但我还想为每封电子邮件附上B列的相应工作簿。
因此,例如,发送给收件人1的电子邮件将包含文件file1.xls,发送给收件人2的电子邮件将包含文件file2.xls,依此类推。
这是我的代码:
Sub Macro1()
ActiveWorkbook.Save
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim fromAdr As String
Dim subject As String
Dim recip As String
Dim numSend As Integer
Dim Attachment1 As String
' Mail settings
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
' Mail fields
fromAdr = """example@example.com"
recip = Range("Q1").Value
Debug.Print strbody
subject = "Orders fondsen"
strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
"Please find the document..."
' Fields layout
strbody = strbody & vbNewLine & vbNewLine & "Text"
Debug.Print strbody
strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"
' Location attachment
Attachment1 = "file-path"
' send mail
On Error GoTo handleError
With iMsg
Set .Configuration = iConf
.To = recip
.CC = ""
.From = fromAdr
.subject = subject
.TextBody = strbody
.AddAttachment Attachment1
.Send
End With
numSend = numSend + 1
GoTo skipError
handleError:
numErr = numErr + 1
oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:
On Error GoTo 0
MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
GoTo endProgram
cancelProgram:
MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"
endProgram:
Application.Interactive = True
Set iMsg = Nothing
Set iConf = Nothing
Set dp = Nothing
End Sub
目前此代码会发送一封包含一个附件的电子邮件。 我对vba是全新的,所以我不知道该如何做到这一点,但有人可以告诉我让我的代码做我想做的事吗?
P.S。我在这一行也遇到了错误,我不确定原因:
oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
提前致谢
答案 0 :(得分:0)
您需要添加一个循环,以便您的代码可以选择每个收件人并为每个收件人添加附件。
Sub Macro1()
ActiveWorkbook.Save
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim fromAdr As String
Dim subject As String
Dim recip As String
Dim numSend As Integer
Dim Attachment1 As String
' Mail settings
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
' Add the loop
Range("Q1").Select
While ActiveCell.Value <> ""
' Mail fields
recip = ActiveCell.Value
Debug.Print strbody
strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
"Please find the document..."
' Fields layout
strbody = strbody & vbNewLine & vbNewLine & "Text"
Debug.Print strbody
strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"
' Location attachment
Attachment1 = Range("B" & ActiveCell.Row).Value
' send mail
On Error GoTo handleError
With iMsg
Set .Configuration = iConf
.To = recip
.CC = ""
.From = "example@example.com"
.subject = "Orders fondsen"
.Body = strbody
.AddAttachment Attachment1
.Send
End With
ActiveCell.Offset(1,0).Select
Wend
numSend = numSend + 1
GoTo skipError
handleError:
numErr = numErr + 1
oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:
On Error GoTo 0
MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
GoTo endProgram
cancelProgram:
MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"
endProgram:
Application.Interactive = True
Set iMsg = Nothing
Set iConf = Nothing
Set dp = Nothing
End Sub
此代码或类似的代码应该可以使用。