Outlook 2007 VBA 全域通訊清單(GAL) Global Address List, dump to file


Outlook 全域通訊清單(GAL)

原來以為很簡單, 但是做了一下, 還是有些巧妙的地方要注意

現在要寫碼的時候, 都習慣用 GOOGLE 找一下, 看看有沒有現成的.

找到這個中文網頁 (CODE-使用Outlook VBA列出所有人員信箱), 是直接在 OUTLOOK VBA 底下, 把outlook 地址列表輸出存到一個檔裡面, 用的是 BASIC PRINT 的方法, 不過試了一下, 必要改一下才能正常運作, 俺現有是 outlook 2007, win7

Sub obtain_address_list()

'ref :

'modofied code and comments, 2013-06-20, xiaolaba
'result, some users name has not dump to file properly, did not know why
'can not be used

Dim oGAL As AddressList

'revised following sentens, otherwise compile error
Set oGAL = GetObject("", "Outlook.application").GetNamespace("MAPI").AddressLists.Item("全域通訊清單")

'try, not working at all
'Set oGAL = GetObject("", "Outlook.application").GetNamespace("MAPI").AddressLists("All Contacts")

Dim oEntry As AddressEntry, oExchUser As ExchangeUser

'Open "B:\AllEmailList.txt" For Output As #1    'not working, no B Drive equipped, win7
'Open "C:\AllEmailList.txt" For Output As #1    'not working, C drive is possble not allowed to write, win7
Open "D:\xiaolaba_EmailList.txt" For Output As #1   'it works, write file to Drive is ok

For Each oEntry In oGAL.AddressEntries

If oEntry.AddressEntryUserType = olExchangeUserAddressEntry Then

Set oExchUser = oEntry.GetExchangeUser()

Print #1, oExchUser.Alias; ",";

Print #1, oExchUser.Name; ",";

Print #1, oExchUser.PrimarySmtpAddress

End If


Close #1

Set oGAL = Nothing  'release memory
Set oExchUser = Nothing 'release memory

End Sub

no dump some address
可是很快就發現一個問題, 輸出的檔案只有3K大小, 依照地址表的裡面聯絡人數量, 絕對不只這個數, 對比後發現, 有地球圖案加小人的那些, 全部都沒有輸出, 改了一下也不得要領, 所以尋找另外的方案.



再找到另外一個網頁 (Getting User Names from Outlook Into Excel), 不過是在 EXCEL VBA 底下, 把 outlook 地址列表填入EXCEL SHEET, 用的是 EXCEL VBA 方法, 測試了一下, 必要改一下才能正常運作, 俺現有是 outlook 2007, win7. 可是很快有出現了另一個問題, 只要 name 和 email address 同時輸出, 一陣子之後錯誤停頓, 無法完全, 不知道要如何改了

Sub Network_Users()

'2013-JUN-21, modified by xiaolaab, add some comments

'   Date   Ini Modification
'   04/10/11 CWH Initial Programming

On Err GoTo ErrHandler

'To remove dependency on “Microsoft Outlook 14.0 Object Library” reference…
'               LateBinding   EarlyBinding           Purpose
Dim olA     As Object       'Outlook.Application    Start Outlook (OL)
Dim olNS    As Object       'Namespace              OL identifiers context
Dim olAL    As Object       'AddressList            An OL address list
Dim olAE    As Object       'AddressEntry           An Address List entry

Dim lo      As ListObject   'An Excel Table

'Create a ListObject/Table in the spreadsheet
With ActiveSheet
.Cells.ClearContents                    'Clear worksheet completely
.Cells.ClearFormats                     'Clear formats as well
.Cells(4, 1) = "Names"                    'Add a column heading
.ListObjects.Add(1, .Cells(4, 1), , xlYes).Name = "Names"
Set lo = .ListObjects("Names")
End With

'Open Outlook, set context, open “All Users” address list
Set olA = CreateObject("Outlook.Application")
Set olNS = olA.GetNamespace("MAPI")
'Set olAL = olNS.AddressLists("All Users")
'Set olAL = olNS.AddressLists("All Contacts")
Set olAL = olNS.AddressLists.Item("全域通訊清單")

'Add each address entry name to the Excel Table
For Each olAE In olAL.AddressEntries
lo.ListRows.Add.Range(1, 1) = olAE.Name
'below is not working, dump is stopped after few names, runtime error 91, did not know why
lo.ListRows.Add.Range(1, 1) = olAE.GetExchangeUser.PrimarySmtpAddress

'Format Results
'    lo.HeaderRowRange.Style = ActiveWorkbook.Styles("Heading 1")   'not working
'    lo.DataBodyRange.Style = ActiveWorkbook.Styles("Output")   'not working
ActiveWindow.FreezePanes = True

'Do this ONLY if you want to close Outlook


If Err.Number <> 0 Then MsgBox _
" Network_Users – Error#" & Err.Number & vbCrLf & _
Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
On Error GoTo 0

End Sub


再次找一下, 看來這個網頁 (匯出GAL 全域通訊清單) 有點像樣, 同樣是 OUTLOOK VBA 底下, 把outlook 地址列表輸出存到一個EXCEL檔裡面, 雖然還有些地方還不明白, 不過算是達到目標, 成功. 俺現有是 outlook 2007, win7

Sub outlook_GAL_output_excel_test()


'modified by xiaolaba JUN/21/2013, some comments

'Dim ExcelSheet As excel.Application
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Visible = True

Dim intCounter As Integer

Dim outApp As Outlook.Application
Dim outNms As Outlook.NameSpace
Dim outAddr As Outlook.AddressList
Dim outRcpts As Outlook.AddressEntries
Dim outRcpt As Outlook.AddressEntry
Set outApp = New Outlook.Application
Set outNms = outApp.GetNamespace("MAPI")
Set outAddr = outNms.AddressLists("全域通訊清單")

'Set outAddr = outNms.AddressLists("Global Address List")

Set outRcpts = outAddr.AddressEntries

'On Error GoTo hError
On Error Resume Next
Application.DisplayAlerts = False

intCounter = 1  'if no this line, the first output was not dummped

For Each outRcpt In outRcpts

y = 1   'column index, reset at every loop start

objExcel.Cells(intCounter, y).Value = outRcpt.Name  'store Name to 1st cell
y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.Address
'        y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.AddressEntryUserType
'        y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.Class
'        y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.ID
'        y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.PropertyAccessor
'        y = y + 1
'        objExcel.Cells(intCounter, y).Value = outRcpt.DisplayType
'        y = y + 1
objExcel.Cells(intCounter, y).Value = outRcpt.GetExchangeUser.PrimarySmtpAddress    'store email address to cell next right side

intCounter = intCounter + 1

Next outRcpt



Set objExcel = Nothing

Set outApp = Nothing
Set outNms = Nothing
Set outAddr = Nothing
Set outRcpts = Nothing

Application.DisplayAlerts = True

'Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext

End Sub


匯出GAL 全域通訊清單


CODE-使用Outlook VBA列出所有人員信箱

Getting User Names from Outlook Into Excel

Getting User Names from Outlook Into Excel





WordPress.com Logo

您的留言將使用 WordPress.com 帳號。 登出 / 變更 )

Twitter picture

您的留言將使用 Twitter 帳號。 登出 / 變更 )


您的留言將使用 Facebook 帳號。 登出 / 變更 )

Google+ photo

您的留言將使用 Google+ 帳號。 登出 / 變更 )

連結到 %s