使用Access VBA从辅助电子邮件导入Outlook联系人

Sub ImportContactsFromEmail()
    Dim olApp As Object ' Outlook.Application
    Dim olNamespace As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olItems As Object ' Outlook.Items
    Dim olContact As Object ' Outlook.ContactItem
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    ' 创建Outlook应用程序对象
    Set olApp = CreateObject("Outlook.Application")
    
    ' 获取Outlook命名空间
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' 获取默认联系人文件夹
    Set olFolder = olNamespace.GetDefaultFolder(10) ' 10代表联系人文件夹
    
    ' 获取联系人列表
    Set olItems = olFolder.Items
    
    ' 打开Access数据库
    Set db = CurrentDb
    
    ' 创建联系人表
    db.Execute "CREATE TABLE Contacts (FirstName TEXT, LastName TEXT, Email TEXT)"
    
    ' 遍历联系人列表并导入到Access数据库
    For Each olContact In olItems
        ' 创建新的记录
        Set rs = db.OpenRecordset("Contacts", dbOpenDynaset)
        rs.AddNew
        
        ' 设置联系人信息
        rs("FirstName") = olContact.FirstName
        rs("LastName") = olContact.LastName
        rs("Email") = olContact.Email1Address
        
        ' 保存记录
        rs.Update
        
        ' 关闭记录集
        rs.Close
    Next olContact
    
    ' 释放对象
    Set olContact = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    
    ' 提示导入完成
    MsgBox "导入联系人成功！"
End Sub