Question

我正试图从文件夹中获取电子邮件发件人的详细信息（例如姓名，职称，部门等）。我能够在通讯录中获得所需的详细信息，但是我没有获得有关GAL中联系人的详细信息。

我的代码如下：

Public Sub DisplaySenderDetails()
Dim Sender As Outlook.AddressEntry
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim strColB, strColC, strColD, strColE, strColF, strColG As String
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Dim obj As Object
Dim objNS As Outlook.NameSpace
Dim olItem As Outlook.MailItem
Dim strdate As String 
Dim oExUser As Outlook.ExchangeUser
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries



 ' Get Excel set up
   enviro = CStr(Environ("USERPROFILE"))
       'the path of the workbook
    strPath = enviro & "\Documents\test2.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
      Set xlWB = xlApp.Workbooks.Open(strPath)
      Set xlSheet = xlWB.Sheets("Sheet1")



  Set objNS = GetNamespace("MAPI")
  Set olGAL = objNS.GetGlobalAddressList()
  Set objFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Abc")
  Set objItems = objFolder.Items
  Set olEntry = olGAL.AddressEntries

  For Each obj In objItems

  With obj

    Set Sender = obj.Sender
    Set olItem = obj

  If TypeName(obj) = "MailItem" Then

    On Error Resume Next

    Dim i As Long
    For i = 1 To olEntry.Count

    If olEntry.Item.Address = Sender.Address Then


        Set oExUser = Sender.GetExchangeUser
        rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
        rCount = rCount + 1

        strdate = DateValue(olItem.ReceivedTime)
        If strdate >= #7/1/2016# Then
            strColB = Sender.Name
            strColC = oExUser.JobTitle
            strColD = oExUser.Department
            strColE = oExUser.PrimarySmtpAddress
            strColF = olItem.Subject
            strColG = olItem.ReceivedTime


            xlSheet.Range("B" & rCount) = strColB
            xlSheet.Range("C" & rCount) = strColC
            xlSheet.Range("D" & rCount) = strColD
            xlSheet.Range("E" & rCount) = strColE
            xlSheet.Range("F" & rCount) = strColF
            xlSheet.Range("G" & rCount) = strColG

            strColB = ""
            strColC = ""
            strColD = ""
            strColE = ""
            strColF = ""
            trColG = ""
        Else
            Exit For
        End If
    End If
    Next i
End If

End With
Next

Set obj = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing

End Sub

Answer 1

我正在使用以下功能

Private Function getSmtpMailAddress(sMail As Outlook.mailItem) As String
    Dim strAddress As String
    Dim strEntryId As String
    Dim objRecipient As Outlook.Recipient
    Dim objSession As Outlook.NameSpace
    Dim objAddressentry As Outlook.AddressEntry
    Dim objExchangeUser As Outlook.ExchangeUser
    Dim objReply As Outlook.mailItem

    On Error GoTo ErrHandler

    If sMail.SenderEmailType = "SMTP" Then
        strAddress = sMail.SenderEmailAddress
    Else
        Set objReply = sMail.reply()
        Set objRecipient = objReply.recipients.item(1)

        strEntryId = objRecipient.EntryID

        objReply.Close OlInspectorClose.olDiscard

        Set objSession = getMapiSession

        strEntryId = objRecipient.EntryID

        Set objAddressentry = objSession.GetAddressEntryFromID(strEntryId)
        Set objExchangeUser = objAddressentry.GetExchangeUser()

        strAddress = objExchangeUser.PrimarySmtpAddress()
    End If

    getSmtpMailAddress = strAddress

    Exit Function

ErrHandler:
    Err.Clear
    On Error GoTo 0
    getSmtpMailAddress = "???"
End Function

Helper例程在一个单独的模块中：

Private objNameSpace As NameSpace

Private Sub logonMapiSession()
    Set objNameSpace = Application.GetNamespace("MAPI")

    objNameSpace.Logon Profile:="", Password:="", ShowDialog:=False, NewSession:=False
End Sub

Public Sub logoffMapiSession()
    If Not (objNameSpace Is Nothing) Then
        objNameSpace.Logoff

        Set objNameSpace = Nothing
    End If
End Sub

Public Function getMapiSession() As NameSpace
    If objNameSpace Is Nothing Then
        logonMapiSession
    End If

    Set getMapiSession = objNameSpace
End Function

vba从GAL获取电子邮件发件人详细信息

1 个答案: