群发邮件报错怎么解决

happydip

求助大神，公司更换了发件服务器端口，群发邮件时报错提示“运行时错误-2147220978（8004020e）服务器拒绝了发件人地址。服务器响应为：530 5.7.0 Must issue a STARTTLS command first” ，发件代码怎么修改呀？
使用代码如下：

Sub 分发邮件()
    Dim cm As Variant
    Dim rowCount, endRowNo As Integer

    endRowNo = Cells(3, 1).CurrentRegion.Rows.Count + 1
   
    For rowCount = 3 To endRowNo Step 1
        Cells(rowCount, 5) = ""
    Next
    For rowCount = 3 To endRowNo Step 1
      If Cells(rowCount, 6).Value = 1 Then
        Set cm = CreateObject("CDO.Message")                     '创建对象
        With cm
            .From = Cells(1, 4).Value                            '设置发信人的邮箱
            .To = Cells(rowCount, 1).Value                       '设置收信人的邮箱
            .Subject = Cells(rowCount, 2).Value       '主题
            .TextBody = Cells(1, 7).Value                        '使用文本格式发送邮件
            .AddAttachment Cells(rowCount, 4).Value
        End With
        stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址
        With cm.Configuration.Fields
            .Item(stUl & "smtpserver") = "mail.ebfcn.com.cn"     'SMTP服务器地址
            .Item(stUl & "smtpserverport") = 587                  'SMTP服务器端口
            .Item(stUl & "sendusing") = 2                        '发送端口
            .Item(stUl & "smtpauthenticate") = 1                 '
            .Item(stUl & "sendusername") = "XX@ebfcn.com.cn"  '发送方邮箱名称
            .Item(stUl & "sendpassword") = "password!"       '发送方邮箱密码
            .Update
        End With
        cm.Send                                                  '执行发送
        Set cm = Nothing                                         '发送成功后即时释放对象
      End If
        Cells(rowCount, 5) = "√"
    Next
End Sub

smsn

.Item(stUl & "smtpusessl") = True
加个这个看看

opiona

发送邮件的DLL 不需要Outlook 支持32和64位系统

https://club.excelhome.net/thread-1629293-1-1.html