从Outlook导入联系人组-Excel VBA [英] Import contact group from outlook - excel vba
本文介绍了从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屋!
查看全文