获取收件人的电子邮件地址（Outlook）

Question

我有一个可以串在一起的代码，可以将发送的电子邮件记录到Excel工作表中，这样我就可以将该数据用于其他分析。

在其中，我将其名称解析为电子邮件，因为Outlook缩短了该名称（“ Jimenez，Ramon” = email@address.com），因为Outlook配置了此功能，并且当我向公司中的任何人发送电子邮件时它们都可以工作在我的通讯录中。

现在，当我向外部的任何人发送电子邮件时，默认情况下默认为lastName，firstName，因此它不会转换并记录它。

我以为我在这里拥有的代码已经做到了，但是我想没有。我已经走了这么远，我根本不是软件专家。有人对我也可以包括在内有见识吗？请参见下面的代码：

Private WithEvents Items As Outlook.Items
Const strFile As String = "C:Usersa0227084Videoswork	est.xlsx"

Private Sub Application_Startup()
  Dim OLApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set OLApp = Outlook.Application
  Set objNS = OLApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then



    Set Msg = item
    ' ******************

    FullName = Split(Msg.To, ";")

    For i = 0 To UBound(FullName)

    If i = 0 Then
        STRNAME = ResolveDisplayNameToSMTP(FullName(i))
        Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
    ElseIf ResolveDisplayNameToSMTP(FullName(i)) <> "" Then
        STRNAME = ResolveDisplayNameToSMTP(FullName(i))
        Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
    End If

    Next i


    'Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))

  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Sub tes2t()



End Sub
Function getRecepientEmailAddress(eml As Variant)
    Set out = CreateObject("System.Collections.Arraylist") ' a javascript-y array

    For Each emlAddr In eml.Recipients
        If Left(emlAddr.Address, 1) = "/" Then
            ' it's an Exchange email address... resolve it to an SMTP email address
            out.Add ResolveDisplayNameToSMTP(emlAddr)
        Else
            out.Add emlAddr.Address
        End If
    Next
    getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith@myco.com)
    ' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
    ' source:  https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel

    Dim OLApp As Object 'Outlook.Application
    Dim oRecip As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim oEDL As Object 'Outlook.ExchangeDistributionList

    Set OLApp = CreateObject("Outlook.Application")
    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                    ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
        End Select
    End If
End Function
Sub Write_to_excel(str1 As String, str2 As String, str3 As String)
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWH As Worksheet

Set xlApp = CreateObject("Excel.Application")

With xlApp
.Visible = True
.EnableEvents = False
End With

Set sourceWB = Workbooks.Open(strFile, False, False)
Set sourceWH = sourceWB.Worksheets("Sheet1")



  sourceWB.Activate
  With sourceWH
        lastrow = .Cells(.rows.Count, "A").End(xlUp).Row
  End With



    sourceWH.Cells(lastrow + 1, 1) = str1
    sourceWH.Cells(lastrow + 1, 2) = str2
    sourceWH.Cells(lastrow + 1, 3) = str3

sourceWB.Save
sourceWB.Close

End Sub

关于，拉蒙