在主 SMTP 和其他 smtp 上提取交换用户信息匹配

Question

我正在使用 excel VBA 从 OneNote 中查找粘贴在表单出勤记录中的列表，我正在从超链接中提取电子邮件。我正在尝试将其与交换用户信息相匹配以拉回 Outlook 信息。如果电子邮件与主 SMTP 地址匹配，我会让它正常工作。有些是通过 OneNote 的其他 smtp 地址（结婚前的姓名）来的，但没有找到。在 Exchange 中，主 SMTP 更改为已婚名称，而婚前 smtp 则成为次要名称。如果主要不匹配，我希望能够匹配到辅助 smtp。

这是有效的代码。原谅非高级编码，因为我正在从谷歌搜索中修补它。

获取电子邮件地址和单元格范围以传递给 Call 语句。

Sub Get_Outlook_Data()
Dim rngEmails As Range
Dim cl As Range
Dim clrow As Long
Dim clcell As String

With Worksheets("OneNote Attendance List")
    Set rngEmails = Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
End With

For Each cl In rngEmails
    cl.Select
    clrow = ActiveCell.Row
    clcell = "B" & clrow
    If Len(cl.Value) > 0 Then
        Call GetOLData(cl.Value, clcell)
    Else
        'No email in cell, ignore it
    End If
Next cl
End Sub

此子正在收集 SMTP 上的 Exchange 用户信息

Sub GetOLData(EmailAddress As String, StartCell As String)
    Dim OutApp 'As Outlook.Application
    Dim OutMail 'As Object
    Dim OutRecipients 'As Outlook.Recipient
    Dim Alias As String
    Dim JobT As String
    Dim Dpt As String
    Dim City As String
    Dim Ste As String
    Dim Off As String
    Dim Fnm As String
    Dim Lnm As String
    Dim Dnm As String
    Dim PosCd As String
    Dim ID As String
    Dim Cmpy As String


    On Error Resume Next
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
    OutRecipients.Resolve

    Alias = OutRecipients.addressEntry.GetExchangeUser.Alias
    JobT = OutRecipients.addressEntry.GetExchangeUser.JobTitle
    Dpt = OutRecipients.addressEntry.GetExchangeUser.Department
    City = OutRecipients.addressEntry.GetExchangeUser.City
    Ste = OutRecipients.addressEntry.GetExchangeUser.SateOrProvince
    Off = OutRecipients.addressEntry.GetExchangeUser.OfficeLocation
    Fnm = OutRecipients.addressEntry.GetExchangeUser.FirstName
    Lnm = OutRecipients.addressEntry.GetExchangeUser.LastName
    Dnm = OutRecipients.addressEntry.GetExchangeUser.Name
    PosCd = OutRecipients.addressEntry.GetExchangeUser.PostalCode
    ID = OutRecipients.addressEntry.GetExchangeUser.ID
    Cmpy = OutRecipients.addressEntry.GetExchangeUser.CompanyName

    ActiveCell.Offset(0, 1).Value = Alias
    ActiveCell.Offset(0, 2).Value = JobT
    ActiveCell.Offset(0, 3).Value = Dpt
    ActiveCell.Offset(0, 4).Value = City
    ActiveCell.Offset(0, 5).Value = Ste
    ActiveCell.Offset(0, 6).Value = Off
    ActiveCell.Offset(0, 7).Value = Fnm
    ActiveCell.Offset(0, 8).Value = Lnm
    ActiveCell.Offset(0, 9).Value = Dnm
    ActiveCell.Offset(0, 10).Value = PosCd
    ActiveDell.Offset(0, 11).Value = ID
    ActiveDell.Offset(0, 12).Value = Cmpy


    Set OutRecipients = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    On Error GoTo 0
End Sub

任何帮助都会很棒。

Answer 1

我要做的第一件事是删除On Error Resume Next，因为它隐藏了您的所有问题。如果要进行错误处理，请处理错误。永远不要跳过它并期望其余代码运行。如果您想跳过该电子邮件地址并继续前进，那么您将让它转到子错误的末尾。

我还注意到您没有使用“StartCell”，因此我添加了一些可以使用它的代码。

代码清理：

Sub Get_Outlook_Data()
    Dim rngEmails As Range
    Dim cl As Range

    With Worksheets("OneNote Attendance List")
        Set rngEmails = .Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
    End With

    For Each cl In rngEmails
        If Len(cl.Value) > 0 Then
            Call GetOLData(cl.Value, "B" & cl.Row)
        End If
    Next cl
End Sub

Sub GetOLData(EmailAddress As String, StartCell As String)
    Dim OutApp                                   'As Outlook.Application
    Dim OutMail                                  'As Object
    Dim OutRecipients                            'As Outlook.Recipient

    'On Error Resume Next ' Never do this
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
    OutRecipients.Resolve

    With OutRecipients.addressEntry.GetExchangeUser
        ActiveCell.Offset(0, 1).Value = .Alias
        ActiveCell.Offset(0, 2).Value = .JobTitle
        ActiveCell.Offset(0, 3).Value = .Department
        ActiveCell.Offset(0, 4).Value = .City
        ActiveCell.Offset(0, 5).Value = .SateOrProvince
        ActiveCell.Offset(0, 6).Value = .OfficeLocation
        ActiveCell.Offset(0, 7).Value = .FirstName
        ActiveCell.Offset(0, 8).Value = .LastName
        ActiveCell.Offset(0, 9).Value = .Name
        ActiveCell.Offset(0, 10).Value = .PostalCode
        ActiveCell.Offset(0, 11).Value = .ID
        ActiveCell.Offset(0, 12).Value = .CompanyName
    End With

    Set OutRecipients = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    'On Error GoTo 0
End Sub