从Outlook导入联系人组-Excel VBA [英] Import contact group from outlook - excel vba

问题描述

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

I have the following code to import all contacts from 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

我只需要导入属于某个联系人组的联系人.如何获得通讯录组属性?它以某种方式暴露了吗?

I need to import only those which belong to a certain contact group. How can I get the contacts group property? Is it somehow exposed?

推荐答案

该子例程从"MyGroupName"联系人组检索名称 在Outlook中，并在活动工作表中列出它们.

The subroutine retrieves names from the "MyGroupName" contact group in Outlook and lists them in the active worksheet.

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的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！