vba批量发送带多个附件的邮件

merlinec

想要批量发送邮件，但是有些邮箱是需要接受多个附件的。
下面有这个代码只能是F列添加的一个附件通过邮件发送。
怎么修改，才能达到F列之后的所有列(G\H\I.......)都成为添加附件的单元格



For rowCount = 2 To endRowNo
A = Application.WorksheetFunction.Clean(Worksheets("Sheet1").Cells(rowCount, 6))
.Attachments.Add A


先谢谢了!

约定的童话

单元格可以放置多个附件地址，分号隔开，然后用m=split([f2],";")获取数组，然后数组循环批量添加即可

闻启学

建议用2楼的
For rowCount = 2 To endRowNo
m=split([f2],";")
for i=0 to ubound(m)
   .Attachments.Add m(i)
next


next

merlinec

闻启学 发表于 2023-3-11 22:43
建议用2楼的
For rowCount = 2 To endRowNo
m=split([f2],";")

修改后，就无法运行了，麻烦看看下面的代码哪里有问题
Sub Button3_Click()
On Error Resume Next
Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim Signature As String
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
Set objOutlook = New Outlook.Application
For rowCount = 2 To endRowNo
a = Split([f2], ";")
For i = 0 To UBound(a)
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.To = Cells(rowCount, 2)
.CC = Cells(rowCount, 3)
.Subject = Worksheets("Sheet1").Cells(2, 4)
.Body = Worksheets("Sheet1").Cells(2, 5)
.Attachments.Add a(i)
next
.Send
End With
Set objMail = Nothing
Next
X = (endRowNo - 1) & "Sent successfully"
MsgBox X
End Sub

sdytsxd991122

Sub Button3_Click()
On Error Resume Next
Dim rowCount, endRowNo
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim Signature As String
endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
Set objOutlook = New Outlook.Application
For rowCount = 2 To endRowNo
a = Split([f2], ";")
For i = 0 To UBound(a)
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.To = Cells(rowCount, 2)
.CC = Cells(rowCount, 3)
.Subject = Worksheets("Sheet1").Cells(2, 4)
.Body = Worksheets("Sheet1").Cells(2, 5)
if ubound(a) >1 then
for kk = 0 to ubound(a)
.Attachments.Add a(kk)
next
else
.Attachments.Add a(0)
end  if
next
.Send
End With
Set objMail = Nothing
Next
X = (endRowNo - 1) & "Sent successfully"
MsgBox X
End Sub

没测试过，不一定正确

闻启学

merlinec 发表于 2023-3-14 14:45
修改后，就无法运行了，麻烦看看下面的代码哪里有问题
Sub Button3_Click()
On Error Resume Next

不出错才怪
1，这要添加引用  Ms outlook 16.0 *
2，语句顺序错误


Sub Button3_Click()
    On Error Resume Next
    Dim rowCount, endRowNo
    Dim objOutlook As New Outlook.Application
    Dim objMail As MailItem
    Dim Signature As String
    endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
    Set objOutlook = New Outlook.Application
    For rowCount = 2 To endRowNo
        Set objMail = objOutlook.CreateItem(olMailItem)  '//新建邮件
        With objMail
            .To = Cells(rowCount, 2)
            .CC = Cells(rowCount, 3)
            .Subject = Worksheets("Sheet1").Cells(2, 4)
            .Body = Worksheets("Sheet1").Cells(2, 5)
        
            a = Split([f2], ";")
            For i = 0 To UBound(a)
                .Attachments.Add a(i)
            Next
        End With
    .Send
    Next
    Set objMail = Nothing
    X = (endRowNo - 1) & "Sent successfully"
    MsgBox X
End Sub