從 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