Получение адресов электронной почты для получателей (Outlook) - PullRequest
Новая
       4

Получение адресов электронной почты для получателей (Outlook)

0 голосов
/ 07 января 2020

У меня есть код, который мне удалось связать воедино, который записывает мои отправленные электронные письма в таблицу Excel, чтобы я мог использовать эти данные для другого анализа.

В нем он преобразовывает имя в электронная почта как outlook сокращает ее («Хименес, Рамон» = email@address.com), так как outlook настроил это, и это работает, когда я отправляю электронное письмо кому-либо в моей компании, как они есть в моей адресной книге.

Теперь, когда Я отправляю электронное письмо кому-либо за его пределами, по умолчанию используется lastName, firstName, поэтому он не преобразует это и не регистрирует его.

Я думал, что код, который я здесь, уже делает, но я не думаю. Я уже зашел так далеко, и я вовсе не гуру программного обеспечения. У кого-нибудь есть понимание того, как я могу также включить это ?? Пожалуйста, смотрите код ниже: 

  Private WithEvents Items As Outlook.Items
  Const strFile As String = "C:\Users\a0227084\Videos\work\test.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
                Dim PR_SMTP_ADDRESS As String
                PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
                ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_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

Сообщение об ошибке и исправленный код

С уважением, Рамон

1 Ответ

0 голосов
/ 07 января 2020

Прежде всего, нет необходимости создавать новый экземпляр Application в методе ResolveDisplayNameToSMTP: 

Set OLApp = CreateObject("Outlook.Application")

Вместо этого вы можете использовать свойство Application, доступное в Outlook VBA. редактор из коробки.

Во-вторых, вам нужно использовать следующий код для получения SMTP-адреса от объекта AddressEntry: 

  Dim PR_SMTP_ADDRESS As String
  Set PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
  ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)

Вместо следующей строки: 

ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address

Подробнее об этом см. В Как получить SMTP-адрес отправителя почтового элемента с помощью объектной модели Outlook? статья.

...