Outlook邮件自动发送

批量发送个性化邮件

Sub SendBulkEmails()
    Dim oApp As Object
    Dim oMail As Object
    Dim lastRow As Long, i As Long

    Set oApp = CreateObject("Outlook.Application")
    lastRow = Sheets("收件人列表").Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastRow
        Set oMail = oApp.CreateItem(0)
        With oMail
            .To = Sheets("收件人列表").Cells(i, 2).Value
            .Subject = Sheets("收件人列表").Cells(i, 3).Value
            .Body = Replace(Sheets("邮件模板").Cells(2, 2).Value, _
                    "{姓名}", Sheets("收件人列表").Cells(i, 1).Value)
            If Sheets("收件人列表").Cells(i, 4).Value <> "" Then
                .Attachments.Add Sheets("收件人列表").Cells(i, 4).Value
            End If
            .Send
        End With
    Next
    MsgBox "邮件发送完成！"
    Set oApp = Nothing
End Sub