excel - 无法发送电子邮件,运行时错误 1004
问题描述
运行此代码时,我得到运行时错误 1004,“应用程序定义的对象定义错误”。此错误显示在第一个函数中以“NumRows = Worksheets("Data")" 开头的行上。有人可以检查此代码并让我知道这里出了什么问题,我是 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
解决方案
我对您的代码进行了一些更正,它在我的最后工作。请试试这个。主要与正确设置工作簿和工作表引用有关,否则您的代码似乎没问题:
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
推荐阅读
- crystal-reports - 带有黄色图标的水晶报表参数
- python - 无法在 Ubuntu 18 上将 ordereddict 安装到特定的 Python 版本
- html - 从 facebook 重定向时没有响应页面
- java - Android / Java:如何并行和重复执行多个http请求?
- javascript - 当用户尝试减去时提醒用户,而没有其他要减去的内容
- javascript - react-native run-android build failed 找不到 com.google.android.gms:play-services-measurement-api:9.8.0
- c# - C#中本地数据库的连接字符串
- node.js - Typescript - 为“promisifed”方法添加类型
- tensorflow - TF / Keras 错误:InputLayer 不是 Checkpointable
- python - 缺少 1 个必需的位置参数:缺少“自我”