Question

正如本文主题中所提到的，我试图通过运行宏来自动发送电子邮件，这样如果单元格J2有单词＆＃34; Send Reminder＆＃34;在其中，然后单元格K2中的电子邮件地址应该发送一个主题标题在单元格L2和主体在单元格M中的电子邮件。我有一个电子邮件列表，范围从单元格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

我已经开放了Outlook，其中包括选择的Microsoft Outlook 14.0对象库的引用，我收到错误说＆＃34;运行时错误＆＃39; 287＆＃39;应用程序定义器或对象定义的错误，如果我尝试调试它，它会突出显示。发送到我的代码中。

任何人都可以帮助指出我做错了什么吗？我尝试过各种类型的代码，根据不同的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中打开多个窗口，其中包含K2：K59中列出的所有电子邮件。例如，如果J2：J59中的三个单元格已发送提醒，我打开3个电子邮件窗口，其中包含cc框中列出的所有电子邮件，而不是包含单个电子邮件的多个窗口或包含所有电子邮件的一个窗口。我想我必须以某种方式关闭循环，但我不确定如何！谢谢你的帮助。

Answer 1

Mail_Object.CreateItem（O）

不应该是

Mail_Object.CreateItem(0)

0而非o

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

尝试此操作（未经测试）

我已对代码进行了评论，因此您在理解代码时不会遇到任何问题，但如果您这样做，则只需回发：）

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 2

由于您打开了Outlook，因此无需执行任何复杂操作。

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

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栏，任何CC进入E1，主题进入E2，任何附件链接进入E3，E4进入选秀或发送以创建选秀或进行发送。< / p>

然后消息体尽可能向下进入E5，每一行将以双返回分隔。无论你使用FirstName包含多于少于几个符号的代码，代码都会将其替换为B列中人员的名字。

直接放入你想要的签名并在其开头旁边的D栏中加上“签名”，这将由单个退货分开。

我有一个excel中的电子邮件地址列表，我需要发送电子邮件到。除了电子邮件地址

3 个答案: