2020-09-17

从Excel中读取邮件地址，通过Outlook Exchange查询姓名和部门，并写回表格。

Sub Run()
Dim emailAddr As String
Dim cell As Range
Dim myXL As Excel.Application
Dim wb As Excel.workbook

Dim colAL As Outlook.AddressLists
Dim oAL As Outlook.AddressList
Dim colAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser

Set colAL = Application.Session.AddressLists

Dim MyExcelPath As String
MyExcelPath = "C:\Users\li_leibj\Desktop\123.xlsx"
Dim myExcelName As String
myExcelName = "123.xlsx"

Set myXL = CreateObject("Excel.Application")
Set wb = myXL.Workbooks.Open(FileName:=MyExcelPath) ', ReadOnly:=False)
myXL.Visible = True
myXL.Windows(myExcelName).Activate
wb.Activate
wb.Worksheets("Sheet2").Activate
wb.Worksheets("Sheet2").Visible = True

wb.Worksheets("Sheet2").Cells(1, 7) = "Name"
wb.Worksheets("Sheet2").Cells(1, 8) = "Department"

For Each cell In wb.Worksheets("Sheet2").Range("F2:F199")
    'Pre-Set to INVALID
    wb.Worksheets("Sheet2").Cells(cell.Row, cell.Column + 1) = "INVALID"
    wb.Worksheets("Sheet2").Cells(cell.Row, cell.Column + 2) = "INVALID"
    emailAddr = cell.Value
    For Each oAL In colAL
       'Address list is an Exchange Global Address List
       If oAL.AddressListType = olExchangeGlobalAddressList Then
           Set colAE = oAL.AddressEntries
           For Each oAE In colAE
               If oAE.AddressEntryUserType = olExchangeUserAddressEntry _
                  Or oAE.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
                  Set oExUser = oAE.GetExchangeUser
                  Debug.Print (oExUser.Name)
                  If oExUser.PrimarySmtpAddress = emailAddr Then
                      wb.Worksheets("Sheet2").Cells(cell.Row, cell.Column + 1) = oExUser.Name
                      wb.Worksheets("Sheet2").Cells(cell.Row, cell.Column + 2) = oExUser.Department
                      Debug.Print (oExUser.Name)
                      Debug.Print (oExUser.Department)
                      Exit For
                  End If
               End If
           Next
       End If
    Next
Next cell

myXL.Workbooks("123.xlsx").Close SaveChanges:=True

End Sub