Excel 无法发送电子邮件，运行时错误1004_Excel_Vba

Excel 无法发送电子邮件，运行时错误1004

excel vba

Excel 无法发送电子邮件，运行时错误1004,excel,vba,Excel,Vba,运行这段代码时，我得到运行时错误1004，“应用程序定义的对象定义的错误”。此错误显示在第一个函数中以“NumRows=工作表（“数据”）开头的行上。有人能检查一下这段代码并告诉我这里出了什么问题吗？我对VBA宏还不熟悉，知识有限 Public Sub loopCheck() Dim NumRows As Integer Dim eID As String Dim eName As String Dim eEmail As String Dim supportGroup As String Di

运行这段代码时，我得到运行时错误1004，“应用程序定义的对象定义的错误”。此错误显示在第一个函数中以“NumRows=工作表（“数据”）开头的行上。有人能检查一下这段代码并告诉我这里出了什么问题吗？我对VBA宏还不熟悉，知识有限

Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String

Dim x As Integer
      Application.ScreenUpdating = False
      NumRows = Worksheets("Data").Range("A5", Range("A5").End(xlDown)).Rows.Count  ' Set numrows = number of rows of data.
      Worksheets("Data").Range("A5").Select ' Select first record.

      For x = 1 To NumRows  ' Establish "For" loop to loop "numrows" number of times.

        eID = Worksheets("Data").Range("A" & x + 4).Value
        eName = Worksheets("Data").Range("B" & x + 4).Value
        eEmail = Worksheets("Data").Range("C" & x + 4).Value
        supportGroup = Worksheets("Data").Range("F" & x + 4).Value
        managerEmail = Worksheets("Data").Range("G" & x + 4).Value
        acName = Worksheets("Data").Range("I" & x + 4).Value


        'Prepare table to be sent locally.
        Worksheets("Data").Range("AA5").Value = eID
        Worksheets("Data").Range("AB5").Value = eName
        Worksheets("Data").Range("AC5").Value = eEmail
        Worksheets("Data").Range("AF5").Value = supportGroup

        managerEmail = managerEmail + ";" + Worksheets("Data").Range("AA1").Value

        'Call Emails function.
        Call Emails(acName, eEmail, managerEmail)

         ActiveCell.Offset(1, 0).Select
      Next

      Application.ScreenUpdating = True
End Sub

Public Sub Emails(x As String, y As String, z As String)

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Dim a As String
Dim b As String
Dim c As String

a = y
b = z
c = x

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
    .To = a
    .CC = b
    .BCC = ""
    .Subject = Worksheets("MF").Range("A1") & c
    .Body = ""
    .display

    Set xInspect = newEmail.getInspector
    Set pageEditor = xInspect.WordEditor

    Worksheets("MF").Range("A9").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A3").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("Data").Range("AA4:AF5").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A5").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A7").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)


    .send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing

End Sub

您的工作表必须处于活动状态，或者必须按如下方式处理您的范围：

NumRows = Worksheets("Data").Range("A5", Worksheets("Data").Range("A5").End(xlDown)).Rows.Count

您的工作表必须处于活动状态，或者必须按如下方式处理您的范围：

NumRows = Worksheets("Data").Range("A5", Worksheets("Data").Range("A5").End(xlDown)).Rows.Count

我已经在你的代码中做了一些修改，它在我这边起作用了。请试试这个。它主要与正确设置工作簿和工作表引用有关，否则代码似乎没有问题：

Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim x As Integer

    Set ws1 = ThisWorkbook.Worksheets("Data") ' Set workbook & worksheet reference 
    Set ws2 = ThisWorkbook.Worksheets("MF")  '' Set workbook & worksheet reference 
    NumRows = ws1.Range("A5", Range("A5").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
     ws1.Range("A5").Select ' Select first record.

      For x = 1 To NumRows  ' Establish "For" loop to loop "numrows" number of times.

        eID = ws1.Range("A" & x + 4).Value
        eName = ws1.Range("B" & x + 4).Value
        eEmail = ws1.Range("C" & x + 4).Value
        supportGroup = ws1.Range("F" & x + 4).Value
        managerEmail = ws1.Range("G" & x + 4).Value
        acName = ws1.Range("I" & x + 4).Value


        'Prepare table to be sent locally.
    With ws1
        .Range("AA5").Value = eID
        .Range("AB5").Value = eName
        .Range("AC5").Value = eEmail
        .Range("AF5").Value = supportGroup

        managerEmail = managerEmail + ";" + ws1.Range("AA1").Value

        'Call Emails function.
        Call Emails(acName, eEmail, managerEmail)

         ActiveCell.Offset(1, 0).Select

    End With
      Next
      Application.ScreenUpdating = True
End Sub

Public Sub Emails(x As String, y As String, z As String)

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Dim a As String
Dim b As String
Dim c As String
Dim str As String
With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

a = y
b = z
c = x

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
Set ws2 = ThisWorkbook.Worksheets("MF")
str = ws2.Range("A1").Value & c

With newEmail
    .To = a
    .CC = b
    .BCC = ""
    .Subject = str
    .Body = ""
    .Display

    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor

   Set ws1 = ThisWorkbook.Worksheets("Data")

    ws2.Range("A9").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

   ws2.Range("A3").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

   ws1.Range("AA4:AF5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A7").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)


    .Send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing
With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

我已经在你的代码中做了一些修改，它在我这边起作用了。请试试这个。它主要与正确设置工作簿和工作表引用有关，否则代码似乎没有问题：

Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim x As Integer

    Set ws1 = ThisWorkbook.Worksheets("Data") ' Set workbook & worksheet reference 
    Set ws2 = ThisWorkbook.Worksheets("MF")  '' Set workbook & worksheet reference 
    NumRows = ws1.Range("A5", Range("A5").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
     ws1.Range("A5").Select ' Select first record.

      For x = 1 To NumRows  ' Establish "For" loop to loop "numrows" number of times.

        eID = ws1.Range("A" & x + 4).Value
        eName = ws1.Range("B" & x + 4).Value
        eEmail = ws1.Range("C" & x + 4).Value
        supportGroup = ws1.Range("F" & x + 4).Value
        managerEmail = ws1.Range("G" & x + 4).Value
        acName = ws1.Range("I" & x + 4).Value


        'Prepare table to be sent locally.
    With ws1
        .Range("AA5").Value = eID
        .Range("AB5").Value = eName
        .Range("AC5").Value = eEmail
        .Range("AF5").Value = supportGroup

        managerEmail = managerEmail + ";" + ws1.Range("AA1").Value

        'Call Emails function.
        Call Emails(acName, eEmail, managerEmail)

         ActiveCell.Offset(1, 0).Select

    End With
      Next
      Application.ScreenUpdating = True
End Sub

Public Sub Emails(x As String, y As String, z As String)

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Dim a As String
Dim b As String
Dim c As String
Dim str As String
With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

a = y
b = z
c = x

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
Set ws2 = ThisWorkbook.Worksheets("MF")
str = ws2.Range("A1").Value & c

With newEmail
    .To = a
    .CC = b
    .BCC = ""
    .Subject = str
    .Body = ""
    .Display

    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor

   Set ws1 = ThisWorkbook.Worksheets("Data")

    ws2.Range("A9").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

   ws2.Range("A3").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

   ws1.Range("AA4:AF5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A7").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)


    .Send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing
With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

经过一些修改，您的程序可以运行，但仍将显示outlook电子邮件创建显示。其次，您应该正确设置对工作表的引用。@skkakkar，下面的代码可以工作，但有时我会得到错误：运行时错误“4605”：由于剪贴板为空或无效，此方法或属性不可用。然后突然结束。它指向第二个功能行，带有“ws2.Range（“A3”）.Copy”。当我尝试运行更多记录时出现此错误，并且此错误仅在某些实例中发生，而不是每次运行时都发生。请查看在程序中添加一些等待时间，如

Application.wait（现在+时间值（“0:00:10”）

，并查看是否有帮助。我将进一步调查此事，并在审查您的错误号相关事宜后通知您。添加等待计时器有帮助，我在每次复制数据之前添加了它。我只是想知道为什么我在调试你的原程序时得到这个错误@ SkkaKar，由于不同的工作簿和工作表引用，我经常遇到不同数量的错误。但在这种情况下，我觉得outlook实例必须处于活动状态才能发送电子邮件。我们的程序将outlook设置为nothing，这些程序确实需要一些时间来打开它们的实例。也许这就是这些错误背后的原因。根据程序执行和outlook活动阶段的同步，错误实例可能会在不同的行上不时更改。经过一些修改，您的程序可以运行，但它仍将显示outlook电子邮件创建显示。其次，您应该正确设置对工作表的引用。@skkakkar，下面的代码可以工作，但有时我会得到错误：运行时错误“4605”：由于剪贴板为空或无效，此方法或属性不可用。然后突然结束。它指向第二个功能行，带有“ws2.Range（“A3”）.Copy”。当我尝试运行更多记录时出现此错误，并且此错误仅在某些实例中发生，而不是每次运行时都发生。请查看在程序中添加一些等待时间，如

Application.wait（现在+时间值（“0:00:10”）