访问 VBA 查询以从 Outlook 导入电子邮件，电子邮件地址未复制

Question

我在 Access VBA 中使用以下查询从 Outlook 导入电子邮件，但是我无法找到任何详细信息来捕获电子邮件地址而不是 From 或与 From 一起。任何帮助都可以申请。

Sub InboxImport()
    Dim SqlString As String
    Dim ConnectionString As String
    Dim EmailTableName As String
    Dim UserIdNum As String
    Dim EmailAddr As String
    Dim ol As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFol As Outlook.Folder

    Set ol = CreateObject("Outlook.Application")
    Set olNS = ol.GetNamespace("MAPI")
    Set olFol = olNS.GetDefaultFolder(olFolderInbox)

    EmailTableName = "MyInbox" 'My table name
    UserIdNum = Environ("USERNAME")  
    EmailAddr = olFol.Parent.Name 
    
    ConnectionString = "Outlook 9.0;MAPILEVEL=Test@Me.com|;PROFILE=Default Outlook Profile;TABLETYPE=0;TABLENAME=Inbox;COLSETVERSION=12.0;DATABASE=C:\Users\ME\AppData\Local\Temp\"

    SqlString = "SELECT [From] As [Sender], [Sender Name] As SenderName, [Subject Prefix] & [Normalized Subject] As Subject, [Contents] As [Body], [Received] As [ReceivedTime]" & _
                " INTO [Copy Of APR_DATA]" & _
                " From [" & ConnectionString & "].[Inbox]"
    DoCmd.RunSQL SqlString
End Sub

Answer 1

设置一个指向 Outlook 收件箱文件夹的链接，将看到显示发件人电子邮件地址或别名的“发件人”字段，但没有其他包含发件人地址的字段。无法通过查询检索可能被屏蔽的电子邮件地址。可以通过读取电子邮件项目的 SenderEmailAddress 属性来检索它。考虑：

' Procedure : Outlook_ExtractMessages
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Extract E-mail Listing
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Usage:
' ~~~~~~
' Call Outlook_ExtractMessages
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2019-07-15              Initial Release
'---------------------------------------------------------------------------------------
Sub Outlook_ExtractMessages()
    Dim oOutlook              As Object    'Outlook.Application
    Dim oNameSpace            As Object    'Outlook.Namespace
    Dim oFolder               As Object    'Outlook.folder
    Dim oItem                 As Object
    Dim oPrp                  As Object
    Const olFolderInbox = 6
    Const olMail = 43
 
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
    If Err.Number <> 0 Then        'Could not get instance, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    End If
    On Error GoTo Error_Handler
 
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
    '    Set oFolder = oOutlook.ActiveExplorer.CurrentFolder    'Process the currently selected folder
    '    Set oFolder = oNameSpace.PickFolder    'Prompt the user to select the folder to process
 
    On Error Resume Next
    For Each oItem In oFolder.Items
        With oItem
            If .Class = olMail Then
                Debug.Print .SenderEmailAddress ' .body, .EntryID, .Subject, .Sender, .SentOn, .ReceivedTime
                'For Each oPrp In .ItemProperties
                '    Debug.Print , oPrp.name, oPrp.Value
                'Next oPrp
            End If
        End With
    Next oItem
 
Error_Handler_Exit:
    On Error Resume Next
    If Not oPrp Is Nothing Then Set oPrp = Nothing
    If Not oItem Is Nothing Then Set oItem = Nothing
    If Not oFolder Is Nothing Then Set oFolder = Nothing
    If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
    If Not oOutlook Is Nothing Then Set oOutlook = Nothing
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_ExtractMessages" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub