从outlook中提取电子邮件地址以获取员工ID的列表

我几乎完成了代码，但我只能拉一个员工ID号。 请参阅下面的代码：

Private Sub CommandButton24_Click() Dim outApp As Object 'Application Dim outTI As Object 'TaskItem Dim outRec As Object 'Recipient Dim outAL As Object 'AddressList Set outApp = GetObject(, "Outlook.Application") Set outAL = outApp.Session.AddressLists.Item("Global Address List") Set outTI = outApp.CreateItem(3) outTI.Assign Set outRec = outTI.Recipients.Add(Range("A2").Value) outRec.Resolve If outRec.Resolved Then Range("B2").Value = outAL.AddressEntries(outRec.AddressEntry.Name).GetExchangeUser.PrimarySmtpAddress Else MsgBox "Couldn't find Employee" End If End Sub 

看起来像这个代码需要做一些改变，这样我可以从列表中提取电子邮件地址。

 Set outRec = outTI.Recipients.Add(Range("A2").Value) 

Answer 1

如果列表在列A上，则尝试循环显示列

例

 Option Explicit Private Sub CommandButton24_Click() Dim olApp As Object 'Application Dim olTaskItem As Object 'TaskItem Dim olRecip As Object 'Recipient Dim olAddList As Object 'AddressList Set olApp = GetObject(, "Outlook.Application") Set olAddList = olApp.Session.AddressLists.Item("Global Address List") Set olTaskItem = olApp.CreateItem(3) Dim i As Long For i = 1 To Range("A" & Rows.Count).End(xlUp).Row olTaskItem.Assign Set olRecip = olTaskItem.Recipients.Add(Cells(i, 1).Value) olRecip.Resolve If olRecip.Resolved Then Cells(i, 2).Value = olAddList.AddressEntries(olRecip.AddressEntry.Name).GetExchangeUser.PrimarySmtpAddress Else MsgBox "Couldn't find Employee" End If Next i End Sub