导出Outlook里的全球通讯录到Excel
2011-02-16 11:23
288 查看
最近整理硬盘文件,发现一个Outlook里的全球通讯录到Excel的代码,但不知道这个文件是什么时候下的了,谨向原作者致敬。
注意:
1、这个代码是写在Excel的模块里的。
2、通讯录中联系人个数多的话,可能时间有点长
注意:
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
相关文章推荐
- 导出Outlook里的全球通讯录到Excel
- 导出Outlook里的全球通讯录到Excel
- OUTLOOK全球默认通讯录的刷新问题!
- B/S下导出系统通讯录信息到Excel中
- exchange2003中的全球通讯录,可以导出保存成EXCEL格式
- google与outlook的通讯录导入导出时,语言差异导致的字段映射问题
- jxl导出excel(通讯录)
- OUTLOOK全球默认通讯录的刷新问题
- 如何把outlook里的通讯录导出
- Outlook 2007导入Excel通讯录
- Exchange 全球通讯录导入基于POP3模式的Outlook
- outlook 2007 通讯录分组导出导入
- Excel模板导出(针对复杂报表的一种解决方式)
- POI导出EXCEL带水印,以及单元格格式设置
- asp.net导出excel数据的常见方法汇总
- poi 导出excel(BigDecimal数据类型)左上角有绿色小三角解决
- C# NPOI 导入与导出Excel文档 兼容xlsx, xls
- asp.net 导出word excel 当前上下文中不存在名称“Encoding”报错问题
- 导出excel
- java POI实现excel导出