下面的程序段（VBA）可以将Outlook中的联系人dump到文件中。如果你们公司有那种全部联系人的通讯录（全球联系人），
你可以先将全部联系人保存到你本机的联系人中，然后运行下面的程序。之后，你就可以在c:下面找到 Text.txt 。里面
包含了全部联系人名单和电话号码... ...2年之前，我就用这样的方法将全部联系人dump出来，编写Delphi程序以资源方式
引用，从而实现本地的地址簿。
程序不完善，虽然可以直接将DistroList中的写入文件中，但是不能保存Recipient的信息（组信息）。
2008年11月22日
Private Sub copyDistroList()
On Error GoTo errHandler
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myDistList As Outlook.DistListItem 'source distribution list contains all contacts
Dim myDistList1 As Outlook.DistListItem 'target distribution list containing contacts A-L
Dim myDistList2 As Outlook.DistListItem 'target distribution list containing contacts M-Z
Dim myFolderItems As Outlook.Items
Dim myRcpnt As Outlook.Recipient
Dim intIterateContactItems As Integer 'track contact items
Dim intIterateDLMemberItems As Integer 'track distribution members
Dim intCountContactItems As Integer 'count contact items
Dim intCountDLMemberItems As Integer 'count distribution members within list
Dim strSourceDistList As String 'source distro list name container
Dim strTargetDistList1 As String 'target 1 distro list name container
Dim strTargetDistList2 As String 'target 2 distro list name container
Dim blnListFound As Boolean 'track if source distro list was found
Dim objSAE ' As Redemption.AddressEntry
Dim myItem As Outlook.ContactItem
strSourceDistList = "KS" 'name of source distro list
strTargetDistList1 = "test1" 'name of target 1 distro list
strTargetDistList2 = "test2" 'name of target 2 distro list
'create Outlook objects
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myFolderItems = myFolder.Items
Set myDistList1 = myOlApp.CreateItem(olDistributionListItem)
Set myDistList2 = myOlApp.CreateItem(olDistributionListItem)
'intialize variables
myDistList1.DLName = strTargetDistList1
myDistList2.DLName = strTargetDistList2
blnListFound = False
Const fsoForAppend = 8
Const PR_CELLULAR_TELEPHONE_NUMBER = &H3A1C001E
Dim objFSO
Dim objTextStream
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.OpenTextFile("C:\Test.txt", fsoForAppend)
'replace with your filename & path
'assign the count of all contact items to variable
intCountContactItems = myFolderItems.Count
'iterate through all Outlook contact items until the source distro list is located
For intIterateContactItems = 1 To intCountContactItems
'check to see if the contact item is a distribution list type
If TypeName(myFolderItems.Item(intIterateContactItems)) = "DistListItem" Then
'set the myDistList object as the DistListItem
Set myDistList = myFolderItems.Item(intIterateContactItems)
'check to see if the distro list is correct source list
If myDistList.DLName = strSourceDistList Then
'assign the distro list member count to variable
intCountDLMemberItems = myDistList.MemberCount
'iterate through all members of the distro list
For intIterateDLMemberItems = 1 To 2
'intCountDLMemberItems
'get the member name, create the recipient, and assign to object variable
Set myRcpnt = myOlApp.Session.CreateRecipient(myDistList.GetMember(intIterateDLMemberItems).Address)
Set myItem = Application.CreateItem(olContactItem)
'ensure the recipient can be resolved in the Exchange director
myRcpnt.Resolve
'is recipient name resolved?
If myRcpnt.Resolved = True Then
Set objSAE = myRcpnt.AddressEntry
objTextStream.WriteLine myRcpnt.Name
myItem.FullName = myRcpnt.Name
myItem.Email1Address = myRcpnt.Address
objTextStream.WriteLine myItem.BusinessTelephoneNumber & "sss"
myItem.ForwardAsVcard
myItem.Save
'if recipient is not resolved then warn the user and move on to the next distro list member
Else
MsgBox "Sorry, I could not resolve the email address for " & _
myDistList.GetMember(intIterateDLMemberItems).Name & "." & _
vbCrLf & "Please write this information down and verify." & _
vbCrLf & "I will move on with the list. Click okay " & _
"to continue.", vbOKOnly + vbCritical, "NOT RESOLVED"
Resume Next
End If
'Debug.Print myDistList.GetMember(intIterateDLMemberItems).Name & _
", " & myDistList.GetMember(intIterateDLMemberItems).Address
'get the next member of the distro list
Next intIterateDLMemberItems
'save the new distro lists
myDistList1.Save
myDistList2.Save
'source distro list was found, so set variable to true
blnListFound = True
'since the source distro list is found, there is no need to continue with the contact items iteration
Exit For
End If
End If
'get the next item within Contacts
Next intIterateContactItems
'Close the file and clean up
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
'raise message box if source distro list was not found
If blnListFound = False Then
MsgBox "Your Source Distribution List was not found", vbOKOnly + vbInformation, "DISTRO LIST NOT FOUND"
End If
setAllToNothing:
'end of subroutine, so ensure all objects are emptied
If Not myOlApp Is Nothing Then
Set myOlApp = Nothing
End If
If Not myNameSpace Is Nothing Then
Set myNameSpace = Nothing
End If
If Not myFolder Is Nothing Then
Set myFolder = Nothing
End If
If Not myDistList Is Nothing Then
Set myDistList = Nothing
End If
If Not myDistList1 Is Nothing Then
Set myDistList1 = Nothing
End If
If Not myDistList2 Is Nothing Then
Set myDistList2 = Nothing
End If
If Not myFolderItems Is Nothing Then
Set myFolderItems = Nothing
End If
If Not myRcpnt Is Nothing Then
Set myRcpnt = Nothing
End If
Exit Sub
errHandler:
MsgBox Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "ERROR"
Resume setAllToNothing
End Sub