我在 excel 中有一个电子邮件地址列表，我需要向其发送电子邮件。主题和 body 在电子邮件地址旁边的单元格中

Question

正如本 post 的主题中所述，我试图通过运行宏自动发送电子邮件，这样如果单元格 J2 中包含单词 "Send Reminder"，那么应该向单元格 K2 中的电子邮件地址发送一封电子邮件，主题标题在单元格 L2 中，在单元格 M 中为 Body。我有一个电子邮件列表，范围从单元格 K2:K59

目前我有以下代码：

    Sub SendEm()

Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "K").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
    With Mail_Object.CreateItem(o)
        .Subject = Range("L2").Value
        .To = Range("K" & i).Value
        .Body = Range("M2").Value
        .Send
    End With
Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub

我已经打开了带有 Microsoft Outlook 14.0 Object 库参考的 Outlook，我收到一条错误消息“Run-time error '287' Application-definer or object-defined 错误，如果我尝试调试它，它会突出显示。发送我的代码。

谁能帮忙指出我做错了什么？我已经尝试过各种类型的代码来根据不同的 youtube 视频等发送电子邮件，但似乎每次都运行进入此错误！

感谢您的提前帮助！

Edit1：我根据建议将代码更新为以下内容，现在是一个不同的问题：

Private Sub CommandButton21_Click()
'~~> Excel Objects/Variables
Dim ws As Worksheet
Dim lRow As Long, i As Long

'~~> Outlook Objects/Variables
Dim OutApp As Object
Dim OutMail As Object
Dim emailRange As Range, cl As Range
Dim sTo As String
Dim subjectRange As Range, c2 As Range
Dim sSubject As String
Dim bodyRange As Range, c3 As Range
Dim sBody As String


'~~> Set your worksheet here
Set ws = ThisWorkbook.Sheets("Sheet11")
'~~> Open Outlook
Set OutApp = CreateObject("Outlook.Application")

With ws

'~~> Get last row from Col J as that is what we
    '~~> are going to check for the condition
    lRow = .Range("J" & .Rows.Count).End(xlUp).Row

 '~~> Loop through the rows
    For i = 2 To lRow
        If .Range("J" & i).Value = "Send Reminder" Then
            '~~> Create new email

Set emailRange = Worksheets("Sheet11").Range("K2:K59")

         For Each cl In emailRange

         sTo = sTo & ";" & cl.Value
         Next
         sTo = Mid(sTo, 2)

Set subjectRange = Worksheets("Sheet11").Range("L2:L59")
          For Each c2 In subjectRange

          sSubject = sSubject & ";" & c2.Value
          Next
          sSubject = Mid(sSubject, 2)

Set bodyRange = Worksheets("Sheet11").Range("M2:M59")

        For Each c3 In bodyRange
        sBody = sBody & ":" & c3.Value
        Next
        sBody = Mid(sBody, 2)

            Set OutMail = OutApp.CreateItem(0)

'On Error Resume Next
            With OutMail
                '~~> Customize your email
                 .To = ""
                 .CC = sTo
                 .BCC = ""
                 .Subject = "typed subject1" & sSubject
                 .Body = ""

                 .Display '<~~ Change to .Send to actually send it
            End With
        End If
    Next i
End With
End Sub

此代码在 outlook 中打开多个 windows，其中包含 K2:K59 中列出的所有电子邮件。例如，如果 J2:J59 中的三个单元格已发送提醒，我会打开 3 封电子邮件 windows 并在抄送框中列出所有电子邮件，而不是多个 windows 和单独的电子邮件或一个 window 与所有电子邮件。我想我必须以某种方式关闭循环，但不确定如何！感谢您的帮助。

Answer 1

因为您打开了 Outlook，所以您不必做任何复杂的事情。

Set Mail_Object = GetObject(, "Outlook.Application")

Answer 2

Mail_Object.CreateItem(o)

不应该是

Mail_Object.CreateItem(0)

0 而不是 o

在下面的代码中，您不需要设置对 MS Outlook 对象库的引用。我在 MS Outlook 中使用 后期绑定。

试试这个（未测试）

我已经对代码进行了注释，因此您理解代码不会有问题，但如果您这样做了，只需 post 返回 :)

Option Explicit

Sub Sample()
    '~~> Excel Objects/Variables
    Dim ws As Worksheet
    Dim lRow As Long, i As Long

    '~~> Outlook Objects/Variables
    Dim OutApp As Object
    Dim OutMail As Object

    '~~> Set your worksheet here
    Set ws = ThisWorkbook.Sheets("Sheet1")
    '~~> Open Outlook
    Set OutApp = CreateObject("Outlook.Application")

    With ws
        '~~> Get last row from Col J as that is what we
        '~~> are going to check for the condition
        lRow = .Range("J" & .Rows.Count).End(xlUp).Row

        '~~> Loop through the rows
        For i = 2 To lRow
            If .Range("J" & i).Value = "Send Reminder" Then
                '~~> Create new email
                Set OutMail = OutApp.CreateItem(0)

                With OutMail
                    '~~> Customize your email
                    .To = ws.Range("K" & i).Value
                    .Subject = ws.Range("L" & i).Value
                    .Body = ws.Range("M" & i).Value

                    .Display '<~~ Change to .Send to actually send it
                End With
            End If
        Next i
    End With
End Sub

Answer 3

我昨天做了类似的事情，这是我使用的代码，希望对你有所帮助。

Sub EmailCopy()
Dim oApp, oMail As Object, X As Long, MyBody As String
    Application.ScreenUpdating = False
    On Error Resume Next
    Set oApp = CreateObject("Outlook.Application")
    For X = 2 To Range("A" & Rows.Count).End(xlUp).Row
        MyBody = Replace(Join(Application.Transpose(Range("E5:E" & Range("D" & Rows.Count).End(xlUp).Row - 1).Value), vbLf & vbLf), "<FirstName>", Range("B" & X).Text)
        MyBody = MyBody & vbLf & vbLf & Join(Application.Transpose(Range("E" & Range("D" & Rows.Count).End(xlUp).Row & ":E" & Range("E" & Rows.Count).End(xlUp).Row)), vbLf)
        Set oMail = oApp.CreateItem(0)
        With oMail
            .To = Range("A" & X).Text
            .cc = Range("E1").Text
            .Subject = Range("E2").Text
            .Body = MyBody
            .Attachments.Add Range("E3").Text
            .Display
            If UCase(Range("E4").Text) = "SEND" Then
                .Send
            ElseIf UCase(Range("E4").Text) = "DRAFT" Then
                .Save
                .Close False
            Else
                MsgBox "You need to choose Draft or Send in cell E4"
                End
            End If
        End With
        Application.ScreenUpdating = True
        Set oMail = Nothing
    Next
    Set oApp = Nothing
End Sub

收件人在 A 列中，名字在 B 列中，任何抄送在 E1 中，主题在 E2 中，任何附件链接在 E3 中，E4 是草稿或发送以创建草稿或发送.

然后邮件正文在E5中往下放，每行用双return隔开。在任何使用大于号和小于号包裹的名字的地方，代码都会将其替换为 B 列中此人的名字。

之后直接输入你想要的签名，然后在 D 列开头旁边输入 "Signature"，这将由单个 return 分隔。

我在 excel 中有一个电子邮件地址列表，我需要向其发送电子邮件。主题和 body 在电子邮件地址旁边的单元格中

I have a list of email addresses in excel that i need to send emails to. The subject and body are in cells besides the email address

excel

outlook

vba

excel-2010