暂无图片
暂无图片
暂无图片
暂无图片
暂无图片
首页 / VBA利用邮箱服务器发送电子邮件

VBA利用邮箱服务器发送电子邮件

VBA语言専攻 2021-10-30
57
【分享成果，随喜正能量】不必去责怪你生命中的任何人和事，来路纵有坎坷，却也教会了你坚强；过往有遗憾，却也让你收获了成长。宽容是一种大智慧。“大肚能容，容天下难容之事；开口便笑，笑世间可笑之人”，弥勒佛在心中，非在眼中。在眼中时时观瞻，刻刻仰止，一旦风生水起，只配得到他老人家的睥睨 。
《VBA信息获取与处理》教程是我推出第六套教程，目前已经是第一版修订了。这套教程定位于最高级，是学完初级，中级后的教程。这部教程给大家讲解的内容有：跨应用程序信息获得、随机信息的利用、电子邮件的发送、VBA互联网数据抓取、VBA延时操作，剪贴板应用、Split函数扩展、工作表信息与其他应用交互，FSO对象的利用、工作表及文件夹信息的获取、图形信息的获取以及定制工作表信息函数等等内容。程序文件通过32位和64位两种OFFICE系统测试。是非常抽象的，更具研究的价值。
教程共两册，八十四讲。今日的内容是专题五“利用VBA发送电子邮件”的第3讲：VBA利用邮箱服务器发送电子邮件

第三节  利用其他邮箱服务器发送电子邮件

在第一和第二节中，我讲解了如何实现利用EXCEL属性设置完成邮件的发送，但很多时候，我们并不是喜欢用OUTLOOK来发送邮件，你可能用的是126的邮箱，可能用的是163的邮箱，等等，那么如何实现利用这些邮件服务器来发送邮件呢？我们这节的内容就给大家以很好的解决方案。
这是我根据我多年的经验编写的第六部教程，这些教程不是单纯的知识讲解更主要的经验的传递，所有的教程中体现的是“积木编程”的思路，大家可以利用我推出的代码，用于实际工作中，尽可能是去修改我推出的代码为自己所用，而不是自己去写代码，那样会很不准确，比如有的朋友让我给测试一段无法运行的代码，我测试后发现就是因为其中一个nothing写成了nohting,更有甚者，是由于逗号的全角问题不能通过，这些问题大家要尽可能的去避免。这讲的代码同样，不要大家去一个个的录入字符，要去用我的代码，然后去修正为自己的设置即可。
下面言归正传，我们讲解利用其它邮件服务器完成我们的邮件发送，我要发送的是包含两个附件的邮件，同时，邮件的主题内容部分是我在事前已经写好到一个文本文件中。我要将这个邮件利用指定的邮箱发送给指定的邮箱。

1  利用邮箱服务器发送邮件的思路分析

由于要利用邮件服务器来完成邮件的发送工作，所以我们要完成对邮件服务器以下必要参数的设置，如发送邮件的邮箱地址；发送邮箱的服务器；发送邮箱的登陆密码；收件人的邮箱地址等等，这个过程看起来是较复杂的，但确实必不可少的关键步骤。除了要完成 上述设置外还要去其他的一些操作上必要的工作，为了能顺利的实现我们任务，我们大概的做一个清单：
  1）代码需要引用Microsoft CDO for Windows 2000库，来完成我们的邮件发送工作。
  2）由于用到的参数较多，有发送邮件的邮箱地址；发送邮箱的服务器；发送邮箱的登陆密码；收件人的邮箱地址；附件的引用；邮件正文的读取文件，等等，所以在代码的实现过程中我们将建立一个function过程来实现邮件的发送。如果邮件发送程序将返回TRUE,如果不成功那么返回false.
  3）在主程序过程中提供上述的参数,并接受函数的返回值，如果为true那么就提示用户邮件发送成功，否则提示没有成功。
  4）在function过程中要校验各个参数是否正常。
  5）在function过程中，要打开需要写入邮件正文的文本文件，然后读取，写入邮件。
  6） 在function过程中要完成附件的添加。在主程序工程中将把每个附件的名称（full name）设置成数组的元素，在function过程中要先判断输入的是否为数组，如果为数组那么拆分数组后逐个添加附件。

2  利用邮箱服务器发送邮件过程中的主程序代码

思路确定之后，我们要一步步的完成我们的工作，首先要完成主程序过程的代码设计，我们在上述思路的清点过程中已经明确了主程序要实现的工作有：必要参数的传递和接受fountion过程的返回值，下面看代码的过程：

Sub myNZB()
myBRR = Array("D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.TXT", "D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.docx")
NN = SendEMailB(Subject:="My Email", FromAddress:="nesng@189.cn", _
    ToAddress:="nesang@189.cn", MailBody:="", _
    SMTP_Server:="smtp.189.cn", BodyFileName:="D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.TXT", Attachments:=myBRR)

If NN = True Then
  MsgBox "邮件发送成功!"
Else
  MsgBox "邮件没有发送成功!"
End If
End Sub
代码的截图：
代码的讲解：
 1） myBRR = Array("D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.TXT", "D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.docx")  这句代码将要添加的附件放到了数组中。
2）NN = SendEMailB(Subject:="My Email", FromAddress:="VBA9668@189.cn", _
    ToAddress:="nesang@189.cn", MailBody:="", _
SMTP_Server:="smtp.189.cn", BodyFileName:="D:\06VBA信息获取与处理(修订一版)\005关于安全生产的通知.TXT", Attachments:=myBRR)
这段代码是利用SendEMailB （）函数来完成邮件的发送。传递的参数有：
Subject:="My Email"
FromAddress:=nesng@189.cn
ToAddress:="nesang@189.cn",
MailBody:="",
SMTP_Server:="smtp.189.cn"
BodyFileName:="E:\NZ\文章\06 VBA信息获取与处理\005关于安全生产的通知.TXT"
Attachments:=myBRR
下面我们还会提到各个参数的意义。
3）If NN = True Then
    MsgBox "邮件发送成功!"
Else
     MsgBox "邮件没有发送成功!"
End If
上述代码根据返回值的不同，从而判断邮件是否发送成功。

3  利用邮箱服务器发送邮件过程中FUNCTION过程的实现代码

在上面的讲解中利用了SendEMailB （）这个函数过程来发送邮件，我们来看看这个过程的具体实现步骤，代码如下：
Function SendEMailB(Subject As String, FromAddress As String, ToAddress As String, _
        MailBody As String, _
        SMTP_Server As String, _
        BodyFileName As String, _
        Optional Attachments As Variant = Empty) As Boolean
'常量的命名
  Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
  Const cdoSendUsingPort = 2
  Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
  Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
  Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
  Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
  Const cdoBasic = 1
  Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
  Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
  Dim objConfig
  Dim objMessage
  Dim Fields
 
 ' 确保所需参数存在且有效
  If Len(Trim(Subject)) = 0 Then
    SendEMailB = False
    Exit Function
  End If

If Len(Trim(FromAddress)) = 0 Then
    SendEMailB = False
    Exit Function
End If

If Len(Trim(SMTP_Server)) = 0 Then
    SendEMailB = False
    Exit Function
End If
'传入的参数
'   Subject:        电子邮件的主题行.
'   FromAddress:    是发送电子邮件的地址
'   ToAddress:      是电子邮件将发送到的地址
'   MailBody:       要作为邮件正文的文本.
'   SMTP_Server:    是传出邮件服务器的名称.
'   BodyFileName:   是将用作消息正文的文本文件的名称.
'   Attachments     要附加到邮件的单个文件名或文件名数组.
 
'引用
  Set objMessage = CreateObject("CDO.Message")
'对象的引用
  Set objConfig = objMessage.Configuration
  Set Fields = objConfig.Fields
 
  With Fields
  .Item(cdoSendUsingMethod) = cdoSendUsingPort
  .Item(cdoSMTPServer) = "smtp.189.cn"   '
  .Item(cdoSMTPServerPort) = 25
  .Item(cdoSMTPConnectionTimeout) = 10
  .Item(cdoSMTPAuthenticate) = cdoBasic
  .Item(cdoSendUserName) = FromAddress   '<发送者邮件地址>
  .Item(cdoSendPassword) = "******"  '<发送者邮件密码>
  .Update
  End With

 '邮件的设置
 
  With objMessage
  '.BodyPart.Charset = "shift-jis"    ' <邮件内容编码（日语可以用）>
  .To = ToAddress                    ' <接收者邮件地址>
  .From = FromAddress                ' <发送者邮件地址,与上面设置相同>
  .Subject = Subject                 '  <邮件主题>
 
 ' .htmlBody                         '  <邮件内容>
 
 '假如传入的参数有内容则引用，也可以从文件中导入
 
  If MailBody <> vbNullString Then
         .htmlBody = MailBody
        Else
          If BodyFileName <> vbNullString Then
                If Dir(BodyFileName, vbNormal) <> vbNullString Then
                   ' 从文件BodyFileName导入正文文本
                    FNum = FreeFile
                    S = vbNullString
                    Body = vbNullString
                    Open BodyFileName For Input Access Read As #FNum
                    Do Until EOF(FNum)
                        Line Input #FNum, S
                        Body = Body & vbNewLine & S
                    Loop
                    Close #FNum
                    .htmlBody = Body
                Else
                    'BodyFileName 没有发现
                    SendEMailB = False
                    Exit Function
                End If
            End If ' MailBody and BodyFileName 都为空
        End If
  '添加附件
      If IsArray(Attachments) = True Then
            ' 附加附件的所有文件.
            For N = LBound(Attachments) To UBound(Attachments)
                ' 如果为数组将每个文件传入
                If Attachments(N) <> vbNullString Then
                    If Dir(Attachments(N), vbNormal) <> vbNullString Then
                        .AddAttachment Attachments(N)
                    End If
                End If
            Next
        Else
            ' 不为数组则传入文件
            If Attachments <> vbNullString Then
                If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
                    .AddAttachment Attachments
                End If
            End If
        End If
 '判断邮件是否发送成功
 
  On Error Resume Next
   Err.Clear
  .Send
   tt = Err.Number
   If Err.Number = 0 Then
      SendEMailB = True
    Else
      SendEMailB = False
      Exit Function
    End If
  End With 
  Set Fields = Nothing
  Set objMessage = Nothing
  Set objConfig = Nothing
End Function
代码的截图：
 
 
代码的解读：
1）' 确保所需参数存在且有效
  If Len(Trim(Subject)) = 0 Then
    SendEMailB = False
    Exit Function
  End If
If Len(Trim(FromAddress)) = 0 Then
    SendEMailB = False
    Exit Function
End If
If Len(Trim(SMTP_Server)) = 0 Then
    SendEMailB = False
    Exit Function
End If
'传入的参数
'   Subject:        电子邮件的主题行.
'   FromAddress:    是发送电子邮件的地址
'   ToAddress:      是电子邮件将发送到的地址
'   MailBody:       要作为邮件正文的文本.
'   SMTP_Server:    是传出邮件服务器的名称.
'   BodyFileName:   是将用作消息正文的文本文件的名称.
'   Attachments     要附加到邮件的单个文件名或文件名数组.

上述代码确保了各个参数的有效性，同时给出了各个参数的意义。当所给的参数是无效的将不能发送邮件，这个很好理解的例如发送邮箱和接受邮箱是空的话自然不能发送邮件的。
2）  Set objMessage = CreateObject("CDO.Message")  这句代码是对CDO的引用，我们发送邮件也是依据这个引用来完成的。
3）With Fields
  .Item(cdoSendUsingMethod) = cdoSendUsingPort
  .Item(cdoSMTPServer) = "smtp.189.cn"   '
  .Item(cdoSMTPServerPort) = 25
  .Item(cdoSMTPConnectionTimeout) = 10
  .Item(cdoSMTPAuthenticate) = cdoBasic
  .Item(cdoSendUserName) = FromAddress   '<发送者邮件地址>
  .Item(cdoSendPassword) = "*****"  '<发送者邮件密码>
  .Update
  End With
以上过程是对邮件的设置包括发送邮件的服务器及密码，大家在利用的时候注意要修改为自己的邮箱及密码设置。
4）With objMessage
  '.BodyPart.Charset = "shift-jis"    ' <邮件内容编码（日语可以用）>
  .To = ToAddress                    ' <接收者邮件地址>
  .From = FromAddress                ' <发送者邮件地址,与上面设置相同>
  .Subject = Subject                 '  <邮件主题>
 
 ' .htmlBody                         '  <邮件内容>

上述代码是对邮件的设置，比较简单，这里不再多讲，下面将对邮件主题内容进行设置。

5）'假如传入的参数有内容则引用，也可以从文件中导入 
  If MailBody <> vbNullString Then
         .htmlBody = MailBody
        Else
          If BodyFileName <> vbNullString Then
                If Dir(BodyFileName, vbNormal) <> vbNullString Then
                   ' 从文件BodyFileName导入正文文本
                    FNum = FreeFile
                    S = vbNullString
                    Body = vbNullString
                    Open BodyFileName For Input Access Read As #FNum
                    Do Until EOF(FNum)
                        Line Input #FNum, S
                        Body = Body & vbNewLine & S
                    Loop
                    Close #FNum
                    .htmlBody = Body
                Else
                    'BodyFileName 没有发现
                    SendEMailB = False
                    Exit Function
                End If
            End If ' MailBody and BodyFileName 都为空
        End If
上述代码完成了邮件主题从另外的文件中进行内容读取的设置，如果有对Input语句不是十分理解的朋友可以参考我的其他教程，在数据库及准数据库中均有讲解。
 
6）'添加附件
      If IsArray(Attachments) = True Then
            ' 附加附件的所有文件.
            For N = LBound(Attachments) To UBound(Attachments)
                ' 如果为数组将每个文件传入
                If Attachments(N) <> vbNullString Then
                    If Dir(Attachments(N), vbNormal) <> vbNullString Then
                        .AddAttachment Attachments(N)
                    End If
                End If
            Next
        Else
            ' 不为数组则传入文件
            If Attachments <> vbNullString Then
                If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
                    .AddAttachment Attachments
                End If
            End If
        End If
上述代码完成了对附件的添加过程，涉及到数组的拆分，文件名的判断，附件的添加。

7）'判断邮件是否发送成功
  On Error Resume Next
   Err.Clear
  .Send
   tt = Err.Number
   If Err.Number = 0 Then
      SendEMailB = True
    Else
      SendEMailB = False
      Exit Function
End If
上述代码完成了对邮件是否发送成功的判断，在整个发送过程中，如果没有发生错误，那么返回值是：SendEMailB = True，否则为false

4  利用邮箱服务器发送邮件的结果

通过主程序和函数过程的实现，我们终于可以完成邮件的发送了，如下图，我们点击运行按钮：

最后在nesang@189.cn 邮箱中将收到，我们发出的邮件，如下图：

以上就是整个邮件发送的过程，这个工程中没有必要要求发送邮件的服务器是打开状态。
本节知识点回向：如何实现利用邮件服务器发送邮件？如何读取指定的文件放到邮件中？如果实现多附件的邮件发送？

本专题参考程序文件：005工作表.XLSM



我20多年的VBA实践经验，全部浓缩在下面的各个教程中，教程学习顺序：
邮件vba数组vba
文章转载自VBA语言専攻，如果涉嫌侵权，请发送邮件至：contact@modb.pro进行举报，并提供相关证据，一经查实，墨天轮将立刻删除相关内容。

评论