自动发送多人邮件---调用本机邮件软件

楚雪飞扬

Sub 邮件发送()
  On Error GoTo ERR
  Dim email As String
  email = "http://schemas.microsoft.com/cdo/configuration/"     '微软服务器网址
  With CreateObject("cdo.message")                                          '调用CDO
      With .Configuration.Fields
          .Item(email & "sendusername") = "***.li@jingan-op.com"            '发送邮箱账号
          .Item(email & "sendpassword") = "123.456a"                       '发送邮箱密码
          .Item(email & "smtpserver") = "mail.jingan-op.com"                 'SMTP服务器，如果不清楚可以百度
          .Item(email & "smtpserverport") = 25                                'SMTP服务器端口，如果不清楚可以百度
          .Item(email & "smtpauthenticate") = 1                               '远程服务器需要验证
          .Item(email & "smtpusessl") = False                                    'SMTP服务器端口
          .Item(email & "sendusing") = 2                                          '使用网络smtp服务器
          .Item(email & "smtpconnectiontimeout") = 60                  '连接超时(秒)
          .Update
      End With
      .From = "ziqiang.li@jingan-op.com"                                              '发件人邮箱
      .To = "****@jingan-op.com" & ";" & "****@jingan-op.com"      '发送多人
      .CC = "****@jingan-op.com"               '抄送
      '.Bcc = MailBcc                                                                    '密送
      .Subject = "邮件自动发送"                                                        '邮件主题
      .TextBody = "正在测试邮件自动发送"                                              '纯文本的邮件内容
      '.HTMLBody = "正在邮件测试"                                            'HTML格式的邮件内容
      .AddAttachment "\\172.168.3.211\综合各类早报\良率崩破日报汇总\" & "良率崩破早报汇总" & "-" & Format(Now - (1), "yyyyMMdd") & ".pptx"                   '添加附件（附件的路径）
      .Send                                                                                  '执行发送
  End With
  MsgBox "邮件发送成功"
  Exit Sub
ERR:
  MsgBox "邮件发送失败!" & Chr(10) & "错误编码:" & ERR.Number & Chr(10) & "错误描述:" & ERR.Description
End Sub