从 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

该子例程从 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