从outlook-excel vba导入联系人组

Question

我有以下代码从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对象属性不足，请读取Recipient.AddressEntry以获取AddressEntry对象。

Answer 2

子程序从"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