OUTLOOK VBA群发邮件失败

wp6865669

同样的VBA不同电脑一台可以正常运行群发邮件，另外一台群发后已发送邮件箱里面有发送记录但是收件箱会出现一封发送失败的邮件提示如下



Deliveryhas failed to these recipients or groups:

abc@xxxx.com
Theemail system had a problem processing this message. It won't try to deliverthis message again.

Diagnosticinformation for administrators:
Generatingserver: PH7PR12MB6666.namprd12.prod.outlook.com
abc@xxxx.com
Remote server returned '554 5.6.0STOREDRV.Submit.Exception:CorruptDataException; Failed to process message dueto a permanent exception with message [BeginDiagnosticData]Store ID'AAAAAHgb2xhdiIhLg0nV+eoaRP8EbSgA' with type 'Folder' isn't an ID of a folder,item or mailbox. CorruptDataException: Store ID'AAAAAHgb2xhdiIhLg0nV+eoaRP8EbSgA' with type 'Folder' isn't an ID of a folder,item or mailbox.[EndDiagnosticData]'
Originalmessage headers:
Received: from PH7PR12MB6666.namprd12.prod.outlook.com ([fe80::ab28:b59e:abe:d7fc]) by PH7PR12MB6666.namprd12.prod.outlook.com ([fe80::ab28:b59e:abe:d7fc%6]) with mapi id 15.20.6178.031; Thu, 16 Mar 2023 23:20:10 +0000MIME-Version: 1.0Content-Type: text/plainDate: Thu, 16 Mar 2023 23:20:10 +0000Message-ID: <PH7PR12MB666627B020AB6D46B4C677049ABC9@PH7PR12MB6666.namprd12.prod.outlook.com>Subject: test

VBA代码如下，代码因该是没有问题，因为有电脑能正常运行。Private Sub CommandButton1_Click()      '要能正确发送并需要对Microseft　Outlook进行有效配置     On Error Resume Next     Dim rowCount, endRowNo     Dim objOutlook As New Outlook.Application     Dim objMail As MailItem     Dim SigString As String     Dim Signature As String      '取得当前工作表与Cells(1,1)相连的数据区行数     endRowNo = Application.WorksheetFunction.CountIfs(Range("A:A"), "<>")      '创建objOutlook为Outlook应用程序对象     Set objOutlook = New Outlook.Application      '开始循环发送电子邮件，比如从第二行开始，第一行是标题     For rowCount = 2 To endRowNo          Set objMail = objOutlook.CreateItem(olMailItem)  '创建objMail为一个邮件对象                           '提取邮件签名             SigString = Worksheets("Sheet1").Cells(2, 6)                If Dir(SigString) <> "" Then                   Signature = GetBoiler(SigString)                Else                   Signature = ""                End If            With objMail               .To = Cells(rowCount, 1).Value  '设置收件人地址（从Excel表的第一列"邮件地址"字段中获得）              .Subject = Cells(rowCount, 2).Value   '设置邮件主题（从Excel表的第二列"邮件主题"字段中获得）              .HTMLBody = Cells(rowCount, 3).Value & Signature  '设置邮件内容（从Excel表的第三列"邮件内容"字段中获得）              .Attachments.Add Cells(rowCount, 4).Value              .Attachments.Add Cells(rowCount, 5).Value              '设置附件（从Excel表的第四列"附件"字段中获得）              .Send           End With               Set objMail = Nothing     '销毁objMail对象        Next           MsgBox ("邮件全部发送完成！")          Set objOutlook = Nothing    '销毁objOutlook对象End Sub  '提取邮件签名子函数Function GetBoiler(ByVal sFile As String) As String    Dim fso As Object    Dim ts As Object    Set fso = CreateObject("Scripting.FileSystemObject")    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)    GetBoiler = ts.readall    ts.CloseEnd Function

zpy2

代码因该是没有问题，因为有电脑能正常运行

如果代码没有问题，应该是服 务 端 拒绝服务了

wp6865669

zpy2 发表于 2023-3-20 08:13
代码因该是没有问题，因为有电脑能正常运行

如果代码没有问题，应该是服 务 端 拒绝服务了

我是不同电脑用用一个帐号的OUTLOOK 登录，台式机电脑有问题，笔记本没问题，以前两个电脑都没有问题，最近突然出现的，所以比较费解。