注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

转,导出Outlook里的全球通讯录到Excel  

2012-03-23 14:30:34|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

导出Outlook里的全球通讯录到Excel

原文:

http://www.cnblogs.com/laoyebin/archive/2011/02/16/1955890.html

最近整理硬盘文件,发现一个Outlook里的全球通讯录到Excel的代码,但不知道这个文件是什么时候下的了,谨向原作者致敬。

注意:
1、这个代码是写在Excel的模块里的。
2、通讯录中联系人个数多的话,可能时间有点长

 

 

Const CdoAddressListGAL = 0
Const CdoUser = 0
Const CdoRemoteUser = 6
#Const EarlyBind = True
Sub Approach()
'Requires Excel 2000 as it uses Array
'A reference must be set to the CDO 1.21 Library for Early Binding
'The file is cdo.dll
Dim X As Variant, CDOList As Variant, TitleList As Variant, CDOitem As Variant
Dim NumX As Long, ArrayDump As Long, i As Long, v As Long, u As Long
Range("a1:R1").Value2 = Array("Global Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", "Country Field", "Assistant Name", "Assistant Phone")
#If EarlyBind Then
Dim objSession As MAPI.Session, oFolder As MAPI.AddressList, oMessage As MAPI.AddressEntry
Set objSession = New MAPI.Session
CDOList = Array(CdoPR_DISPLAY_NAME, CdoPR_GIVEN_NAME, CdoPR_SURNAME, 972947486, CdoPR_ACCOUNT, _
CdoPR_TITLE, CdoPR_OFFICE_TELEPHONE_NUMBER, CdoPR_MOBILE_TELEPHONE_NUMBER, CdoPR_PRIMARY_FAX_NUMBER, _
CdoPR_COMPANY_NAME, CdoPR_DEPARTMENT_NAME, 974716958, CdoPR_STREET_ADDRESS, _
CdoPR_LOCALITY, CdoPR_STATE_OR_PROVINCE, CdoPR_COUNTRY, _
CdoPR_ASSISTANT, CdoPR_ASSISTANT_TELEPHONE_NUMBER)
#Else
Dim objSession As Object, oFolder As Object, oMessage As Object
Set objSession = CreateObject("MAPI.Session")
CDOList = Array(805371934, 973471774, 974192670, 972947486, 973078558, 974585886, _
973602846, 974913566, 975372318, 974520350, 974651422, 974716958, 975765534, _
975634462, 975699998, 975568926, 976224286, 976093214)
#End If
With objSession
.Logon , , False, False
Set oFolder = .GetAddressList(CdoAddressListGAL)
End With
TitleList = Array("GAL Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", _
"Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", _
"Country Field", "Assistant Name", "Assistant Phone")
'Grab 10 records in one hit before writing to sheet
'2000 would be better but Excel skips records
ArrayDump = 10
Cells.Clear
'Add Titles
With Range("A1").Resize(1, UBound(TitleList) + 1)
.Formula = TitleList
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 35
.Font.Bold = True
.Font.Size = 12
End With
UserForm1.Show vbModeless
ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1)
On Error Resume Next
'Some fields may not exist
Application.ScreenUpdating = False
For Each oMessage In oFolder.AddressEntries
Select Case oMessage.DisplayType
Case CdoUser, CdoRemoteUser
i = i + 1
'Reset variant array every after each group of records
If i Mod (ArrayDump + 1) = 0 Then
If NumX * ArrayDump + i > 65535 Then
MsgBox "GAL exceeds 65535 entries - extraction stopped ", vbCritical + vbOKOnly
GoTo FastExit
End If
NumX = NumX + 1
Range("A2").Offset((NumX - 1) * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X
ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1)
i = 1
End If
'Display status to user
If i Mod ArrayDump = 0 Then
UserForm1.LabelProgress.Width = (i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count * UserForm1.FrameProgress.Width
UserForm1.LabelSheetNum = Format((i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count, "percent")
DoEvents
End If
v = 0
' Add detail to each address
For Each CDOitem In CDOList
v = v + 1
X(i, v) = oMessage.Fields(CDOitem)
Next
Case Else
u = u + 1
End Select
Next
'dump remaining entries
Range("A2").Offset(NumX * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X
'cleanup
FastExit:
Unload UserForm1
ActiveSheet.UsedRange.EntireRow.WrapText = False
ActiveSheet.UsedRange.AutoFilter
Columns("A:R").AutoFit
Application.ScreenUpdating = True
Set oFolder = Nothing
Set objSession = Nothing
End Sub

  评论这张
 
阅读(582)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017