Access开发邮件接收功能

Hi，大家好！

最近的天气怎么这么热的，开着小毛驴办点事，感觉都被融化了，这周我们还是接着讲邮件的功能。邮件的发送功能会了，今天我们当然就要来讲收件功能了。

收件的话，我们这里还是要借助outlook来实现，这样就不需要第三方的DLL了，如果和发送一样，用CDO来实现的话，服务器只支持非 SSL 的 POP3，OK费话不多说，我们直接开干，老规矩，开始前，先给个一键三连吧！

1、创建表

首先，我们需要创建一张表，用于保存邮件数据，表结构如下：

表中保存了一些具体的信息，邮件唯一ID（防重复）、发件人姓名、邮箱地址、邮件主题、正文内容、接收时间、处理状态。

2、创建窗体

接收窗体就不用像发送窗体这么复杂了，只要放两个控件，具体如图：

3、添加代码

接着，我们就可以用来添加代码了，具体代码如下：

Public Sub ReceiveOutlookMails()    Dim olApp As Outlook.Application    Dim olNamespace As Outlook.NameSpace    Dim olInbox As Outlook.MAPIFolder    Dim olMail As Outlook.MailItem    Dim olItem As Object    Dim db As DAO.Database    Dim rs As DAO.Recordset    Dim i As Integer    Dim newMailCount As Integer        On Error GoTo ErrorHandler        ' 连接到 Outlook    Set olApp = GetOutlookApp()    Set olNamespace = olApp.GetNamespace("MAPI")        ' 获取收件箱    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)        ' 打开数据库表    Set db = CurrentDb    Set rs = db.OpenRecordset("tbl_ReceivedMails", dbOpenDynaset)        newMailCount = 0        ' 遍历收件箱中的邮件（从最新开始）    For i = olInbox.Items.Count To 1 Step -1        Set olItem = olInbox.Items(i)                ' 确保是邮件项        If TypeOf olItem Is Outlook.MailItem Then            Set olMail = olItem                        ' 检查邮件是否已导入            If Not IsMailImported(olMail.entryID) Then                ' 导入新邮件                rs.AddNew                rs!entryID = olMail.entryID                rs!Subject = Left(Nz(olMail.Subject, ""), 255)                rs!SenderName = Left(Nz(olMail.SenderName, ""), 100)                rs!senderEmail = Left(GetSenderEmail(olMail), 100)                rs!ReceivedTime = olMail.ReceivedTime                rs!BodyText = olMail.Body                               rs!IsRead = Not olMail.UnRead                rs!ImportTime = Now()                rs.Update                                newMailCount = newMailCount + 1                            End If        End If                ' 避免处理过多邮件导致超时        If newMailCount >= 50 Then Exit For    Next i        ' 关闭资源    rs.Close    Set rs = Nothing    Set db = Nothing        ' 显示结果    MsgBox "成功导入 " & newMailCount & " 封新邮件！", vbInformation, "邮件接收完成"    Me.F_ReceivedMails_List.Requery    Exit Sub    ErrorHandler:    MsgBox "邮件接收出错：" & Err.Description, vbCritical, "错误"        ' 清理资源    On Error Resume Next    If Not rs Is Nothing Then rs.Close    Set rs = Nothing    Set db = Nothing    Set olMail = Nothing    Set olInbox = Nothing    Set olNamespace = Nothing    Set olApp = NothingEnd Sub' 获取或创建 Outlook 应用程序实例Private Function GetOutlookApp() As Outlook.Application    Dim olApp As Outlook.Application        On Error Resume Next    ' 尝试连接现有的 Outlook 实例    Set olApp = GetObject(, "Outlook.Application")        If olApp Is Nothing Then        ' 如果没有运行，则创建新实例        Set olApp = CreateObject("Outlook.Application")    End If        On Error GoTo 0    Set GetOutlookApp = olAppEnd Function' 检查邮件是否已导入Private Function IsMailImported(entryID As String) As Boolean    Dim db As DAO.Database    Dim rs As DAO.Recordset    Dim sql As String        Set db = CurrentDb    sql = "SELECT EntryID FROM tbl_ReceivedMails WHERE EntryID = '" & entryID & "'"    Set rs = db.OpenRecordset(sql)        IsMailImported = Not rs.EOF        rs.Close    Set rs = Nothing    Set db = NothingEnd Function' 获取发件人邮箱地址Private Function GetSenderEmail(olMail As Outlook.MailItem) As String    Dim senderEmail As String        On Error Resume Next    ' 尝试获取发件人邮箱地址    If olMail.SenderEmailType = "EX" Then        ' Exchange 地址        senderEmail = olMail.Sender.GetExchangeUser.PrimarySmtpAddress    Else        ' SMTP 地址        senderEmail = olMail.SenderEmailAddress    End If        If senderEmail = "" Then        senderEmail = olMail.SenderEmailAddress    End If        On Error GoTo 0    GetSenderEmail = senderEmailEnd FunctionPrivate Sub Command0_Click()    Call ReceiveOutlookMailsEnd Sub

4、运行测试

最后，就是运行测试了，运行效果不错，大家快去试一下吧！