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

子程序从＆＃34; MyGroupName＆＃34;中检索名称。联络小组在Outlook中，并在活动工作表中列出它们。

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

从outlook导入联系人组 - excel vba

2 个答案: