Access开发邮件发送功能

Hi，大家好！

暑假开始了，不知道各位都有什么精彩的暑期安排呢？或许可以抽出一些时间来学习 Access！嘿嘿！

我们已经讲了好几篇的outlook的文章了，每次的应用都是围绕着outlook的来实现一些邮件的操作，那今天我们就给大家分享邮件发送功能，废话不多说，让我们开干！

再次提醒大家，这次干货满满，开始前先给个一键三连吧！

01、创建窗体

这次我们创建的窗体控件比较多，具体如下：

02、添加代码

这里代码要分好几块，大家依次复制添加

添加一下枚举类型

Option Explicit



' 邮件格式常量枚举，用于指定邮件正文格式

Public Enum EmailFormatEnum

    dpEmailFormatText = 0   ' 纯文本格式

    dpEmailFormatHTML = 1   ' HTML 网页格式

    dpEmailFormatURL = 2    ' 超链接格式（邮件内容是一个网页地址，自动获取并发送网页内容）

End Enum

添加发送邮件函数，注意要替换你自己的配置，这里代码我都写死了，大家也可以自己做一个配置功能！

' 发送邮件函数：通过 CDO 对象配置 SMTP 参数并发送邮件

Public Function SendEmail(ToAddress As String, _

                          Subject As String, _

                          Body As String, _

                          Optional Attachment As String, _

                          Optional CC As String, _

                          Optional BCC As String, _

                          Optional BodyFormat As EmailFormatEnum = dpEmailFormatText _

                          ) As Boolean

    On Error GoTo ErrorHandler

   

    Dim strNameSpace As String

    Dim objMessage As Object ' CDO.Message

    Dim cdoConfig As Object

    Dim SendUserName As String

   

    SendEmail = False

    SendUserName = "你的邮箱地址" ' 发件人邮箱

   

    ' 创建 CDO 对象以进行邮件发送

    Set objMessage = CreateObject("CDO.Message")

    Set cdoConfig = CreateObject("CDO.Configuration")

   

    ' 设置 CDO 配置项，如 SMTP 服务器、端口、凭证等

    strNameSpace = "http://schemas.microsoft.com/cdo/configuration/"

    With cdoConfig.fields

        .Item(strNameSpace & "smtpserver") = "你的发送服务器"

        .Item(strNameSpace & "smtpserverport") = 25

        .Item(strNameSpace & "sendusing") = 2

        .Item(strNameSpace & "smtpauthenticate") = 1

        .Item(strNameSpace & "smtpusessl") = False

        .Item(strNameSpace & "sendusername") = SendUserName

        .Item(strNameSpace & "sendpassword") = "你的密码"

        .Update

    End With

   

    ' 根据不同正文格式设置邮件内容，并发送

    With objMessage

        Set .Configuration = cdoConfig

        .From = SendUserName

        .To = ToAddress

        .CC = CC

        .BCC = BCC

        .Subject = Subject

        .BodyPart.Charset = "UTF-8"

       

        Select Case BodyFormat

            Case dpEmailFormatHTML

                .HTMLBody = Body

            Case dpEmailFormatURL

                .CreateMHTMLBody Body

            Case Else

                .TextBody = Body

        End Select

       

        ' 若有附件，则添加附件

        .AddAttachment Me.txtPath

       

        .fields.Update

        .Send

    End With

   

    SendEmail = True

   

ExitHere:

    ' 释放对象

    Set cdoConfig = Nothing

    Set objMessage = Nothing

    Exit Function

   

ErrorHandler:

    ' 错误处理，显示错误信息

    MsgBox "#" & Err.Number & " SendEmail()" & vbCrLf & Err.Description, vbCritical

    Resume ExitHere

End Function

发送按钮的单击事件

' 发送按钮：调用 SendEmail 函数发送邮件，并根据返回值弹窗提示

Private Sub btnSend_Click()

    If SendEmail(Me.txtTo, Me.txtSubject, Nz(Me.txtPath, ""), Nz(Me.txtCC, ""), Nz(Me.txtBCC, "")) Then

        MsgBox "发送成功", vbInformation

    Else

        MsgBox "失败", vbInformation

    End If

End Sub

浏览按钮的单击事件

' 浏览按钮：打开文件选择对话框，获取单个文件路径并赋值给文本框

Private Sub btnBrowse_Click()

    With Application.FileDialog(msoFileDialogFilePicker)

        .Filters.Clear

        .AllowMultiSelect = False

        .InitialFileName = ""

        If Not .Show Then

            Exit Sub

        End If

        Me.txtPath = .SelectedItems(1)

    End With

End Sub

03、运行测试

代码添加好了，最后，就是运行测试了，这里我还是给大家截个图，亲测，代码肯定是可以的，大家自己在测试时，一定要仔细，还有注意了，部分邮箱（如QQ邮箱）要求必须使用SSI加密。端口也是需要修改的，我这里输入的是25(默认)。

好了，今天的分享就到这里了，这么好用的功能，大家快去试一下吧，原创文章不容易，大家给个三连吧！谢谢大家了！