从outlook导入联系人组 – excel vba

我有以下代码从Outlook导入所有联系人。

Dim olApp As Outlook.Application Dim olNamespace As Outlook.Namespace Dim olFolder As Outlook.MAPIFolder Dim olConItems As Outlook.Items Dim olItem As Object Set olApp = New Outlook.Application Set olNamespace = olApp.GetNamespace("MAPI") Set olFolder = olNamespace.GetDefaultFolder(olFolderContacts) Set olConItems = olFolder.Items 'HERE IS THE PROBLEM I do not know how to do so that there are only contacts from my desired group in the olConItems collection For Each olItem In olConItems If TypeName(olItem) = "ContactItem" Then 'Do something - no problem I just do not want to post unnecessary code End If Next olItem 

我只需要导入属于某个联系人组的那些。 我怎样才能得到联系人组属性？ 它有点暴露吗？

Answer 1

从1循环到DistListItem.MemberCount并调用DistListItem.GetMember – 它将返回Recipient对象。 如果收件人对象属性不够，请阅读Recipient.AddressEntry以获取AddressEntry对象。

Answer 2

该子例程从Outlook中的“MyGroupName”联系人组中检索名称，并将其列在活动工作表中。

 Sub Get_Email_List() Dim I As Integer Dim A1 As String Dim B() As String Dim WSN as String Dim Group as String Dim olApp As Outlook.Application Dim myNamespace As Object Dim myFolder As Object Dim myItem As Object Dim WordApp As Object Application.ScreenUpdating = False WSN = ActiveSheet.Name Group = "MyGroupName" Sheets(WSN).Select Selection.Clear Columns("A:D").Select Selection.NumberFormat = "@" Cells(1, 1).Select Set olApp = New Outlook.Application With olApp Set myNamespace = .GetNamespace("MAPI") Set myFolder = myNamespace.GetDefaultFolder(olFolderContacts) Set myItem = myFolder.Items(Group) For I = 1 To myItem.MemberCount Cells(I + 1, 1) = myItem.GetMember(I).Name Cells(I + 1, 3) = myItem.GetMember(I).Address Next I End With Set olApp = Nothing Set myNamespace = Nothing Set myFolder = Nothing Set myItem = Nothing Range("A1") = "Display Name" Range("B1") = "Last Name" Range("C1") = "Email Address" Range("D1") = "Composite Email Address" Range("A2:B" & I + 1).Select Selection.Cells.Replace What:="'", Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False A1 = "" I = 2 While Cells(I, 1) > "" If InStr(1, Cells(I, 1), ")") > 0 Then _ Cells(I, 1) = Left(Cells(I, 1), InStr(1, Cells(I, 1), "(") - 2) B = Split(Cells(I, 1), " ") Cells(I, 2) = Trim(B(UBound(B, 1))) If I > 1 Then A1 = A1 & "; " A1 = A1 & Trim(Cells(I, 1)) Cells(I, 4) = Cells(I, 1) & " <" & Cells(I, 3) & ">" I = I + 1 Wend ActiveWorkbook.Worksheets(WSN).Sort.SortFields.Clear ActiveWorkbook.Worksheets(WSN).Sort.SortFields.Add Key:=Range("B2:B" & I), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets(WSN).Sort .SetRange Range("A2:D" & I) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Columns("A:C").Select Selection.ColumnWidth = 28 Columns("D:D").Select Selection.ColumnWidth = 48 Range("A1:D1").Select Selection.Font.FontStyle = "Bold" Range("A2").Select With ActiveWindow .SplitColumn = 0 .SplitRow = 1 End With ActiveWindow.FreezePanes = True Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub