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

http://wp.me/ph3BR-TW

Outlook 全域通訊清單(GAL)

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

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

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

Sub obtain_address_list()

'ref :
'http://blog.darkthread.net/post-2010-05-08-outlook-vba-list-gal.aspx

'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

Next

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()

'EXCEL VBA
'ref:
'http://itknowledgeexchange.techtarget.com/beyond-excel/getting-names-from-outlook-into-excel/
'
'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
Next

'Format Results
'    lo.HeaderRowRange.Style = ActiveWorkbook.Styles("Heading 1")   'not working
'    lo.DataBodyRange.Style = ActiveWorkbook.Styles("Output")   'not working
Range("A5").Select
ActiveWindow.FreezePanes = True
Cells.EntireColumn.AutoFit

'Do this ONLY if you want to close Outlook
'olA.Quit

ErrHandler:

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()

'ref:
'http://myblog-johnnyit.blogspot.tw/2009/03/gal.html

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


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

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("全域通訊清單")
'中文ExchangeServer環境預設名稱

'Set outAddr = outNms.AddressLists("Global Address List")
'英文ExchangeServer環境預設名稱

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

objExcel.Application.Quit


'hError:

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

.
.
REF:

匯出GAL 全域通訊清單
http://myblog-johnnyit.blogspot.tw/2009/03/gal.html

http://windowssecrets.com/forums/showthread.php/121886-How-to-retrieve-GAL-info-into-Outlook-contacts-with-VBA

CODE-使用Outlook VBA列出所有人員信箱
http://blog.darkthread.net/blogs/darkthreadtw/archive/2010/05/08/outlook-vba-list-gal.aspx

Getting User Names from Outlook Into Excel

Getting User Names from Outlook Into Excel

使用VBA匯出全域通訊錄
http://yc999.wordpress.com/2010/08/16/%E4%BD%BF%E7%94%A8vba%E5%8C%AF%E5%87%BA%E5%85%A8%E5%9F%9F%E9%80%9A%E8%A8%8A%E9%8C%84/

廣告

EXCEL 2003 寫好的 VBA, 用在 2007 都正常, 直到 excel 2010 就不能執行

http://wp.me/ph3BR-RX

原來是 XP + office 2003  年代時寫好的小工具, 一直都是很順暢的在用.

但是最近有小妹挑了一台小電腦出差用, 發現了一個問題, XP + 內建 office 2010, 執行同樣的 VBA 就報錯

excel2010 error

請教過人家,

http://social.msdn.microsoft.com/Forums/zh-TW/805/thread/edd581aa-3089-46f8-afa0-ee9bce660580

最後確認, 原來這個錯誤是因為,

遺漏: Microsoft Calender Control 2007

取消打鉤, 移除因為沒有用到, 也不存在.

為什麼會自動出現的呢, 翻查 EXCEL 2003 的那個存檔, 裡面也沒用過, 到底如何來的 ?

excel2010 error and why

.
.
報錯之一
'Excel 2003/2007/2010 可以正確運行
    MsgBox ("你所輸入的資料格式都檢查通過, 已填入 Sheet1" + vbCrLf + _
            "不過資料的準確性需要自行判定" + vbCrLf + _
            "可以開印標籤或發EMAIL")

    'Excel 2003/2007 可以, 但是 Excel 2010 不可運行
    'MsgBox ("你所輸入的資料格式都檢查通過, 已經填入 Sheet1" + Chr(13) + _
    '        "不過資料的準確性需要自行判定" + Chr(13) + _
    '        "可以開印標籤或發EMAIL")

 

 

.

.

報錯之二
Private Sub CommandButton載入樣版_Click()

Dim Answer As Boolean   '原來沒有這句, 沒有明確定義, excel2003/2007 可執行, excel 2010 則無法運行

    Answer = MsgBox("所有已經填寫的資料會被取代." + vbCr + _
                    "僅作為觀察用. 如果要填寫資料, 建議首先 [清除所有資料] !!" + vbCr + vbCr + _
                    "你要繼續載入嗎 ?" + vbCr _
                    , vbQuestion + vbYesNo _
                    , "注意!!")

    If Answer = vbNo Then Exit Sub

    Answer = MsgBox("看來你還是需要繼續載入樣板. 記得, 觀察完畢, 務必首先 [清除所有資料] !! 要載入樣板嗎 ?", vbCritical + vbQuestion + vbYesNo, "注意!!")

    If Answer = vbNo Then Exit Sub

    Call pre_set_template

End Sub

.

.

.

再來這個就還沒有頭緒, Trim 和 UCase, 要處理的資料從使用者輸入的字串, 全變大寫, 去掉首位多餘的 [ 空白], 然後存起來

報錯是, [ 找不到專案或程式庫 ]

補充, TextBoxSR, 是一個在 USERFORM 上 TextBox, 名稱改成 TextBoxSR, 方便閱讀而已, 其內容是使用者輸入的資料

string_buffer = Trim(UCase(TextBoxSR))
    TextBoxSR = string_buffer

.

.

.

解決方案

'Excel 2003/2007/2010 可以正確運行
MsgBox ("你所輸入的資料格式都檢查通過, 已經填入 Sheet1" + vbCrLf + _
"不過資料的準確性需要自行判定" + vbCrLf + _
"可以開印標籤或發EMAIL")

'Excel 2003/2007 可以, 但是 Excel 2010 不可運行
'成因, Microsoft VBA 設定引用項目 Calender Control 2007 不存在她的 XP 2010
'錯誤, 找不到項目
'除此以外還有其他莫名其妙的錯誤
'2013-05-16, 回來遇到她的電腦, 確認, 移除以上說明的那個引用項目, 全部問題解決
MsgBox ("你所輸入的資料格式都檢查通過, 已經填入 Sheet1" + Chr(13) + _
"不過資料的準確性需要自行判定" + Chr(13) + _
"可以開印標籤或發EMAIL")

EXCEL VBA – Trim string with specific delimiter 截去特分隔符號後面的字串

http://wp.me/ph3BR-Q7

 

data

item
AN-BA044.5-0.8-9415-7V
AN-BA9090-9.7-0821-51V
AN-BA9191-9.4-0820-51
AN-BA9595-9.6-0798-51V
AN-AFN0505-9.2-9415-7-R.9
AN-AFN0707-9.6-9026-51
ANH-BA9797-9.5-0695-51
ANH-BA9999-9.8-0694-51
ANH-BA2929-2.1-0592-51-R.A
ANH-BA2727-2.0-0490-51-R.4
ANH-BA2929-2.0-0409-51
ANH-BA1515-9.5-0108-51
ANX-BA17.517.5-2.0-0107-51V

AND-2020-9.4-0592-99-R.A
AN-2020-9.0-0592-99

.

.

before trim

nEO_IMG_before trim

after trim, result

nEO_IMG_after trim

.
.

VBA source code


Sub 整理資料()
'''''''''''' 2013-03-26, xiaolaba
''''''''''''

'先查有資料的範圍, 得到最大的行,列號, 計算有多少格資料要處理
最大的列號x = Cells.Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
最大的行號y = Cells.Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

X = 1 ' X & Y 指標指向第一列的第一格
Y = 1

'    Do While X <= 最大的列號x
Y = 2                                   '設定指向第一格
Do While Y <= 最大的行號y
Cells(Y, X).Select

'''ActiveCell = 除去字串中連續兩個的空格(ActiveCell)

'原字串存在 ActiveCell , 分隔號 "-", 第4個位置
'左側資料結果存到右側的 CELL
'右側資料結果存到右側的 CELL + 1
ActiveCell.Offset(0, 1) = 分解字串(ActiveCell, "-", 4, "保存左邊資料")
ActiveCell.Offset(0, 2) = 分解字串(ActiveCell, "-", 4, "保存右邊資料")

Y = Y + 1                       '已處理本格, 指向下一格
Loop
'       X = X + 1                           '已處理本列, 指向右面一列
'   Loop

End Sub

Public Function 分解字串(待處理字串 As String, 特殊分隔字符 As String, 第X個 As Integer, 保留動作 As String) As String

Dim J, i As Integer

原本字串 = Trim(待處理字串)     '先去除字串內首尾沒用的 SPACE, 人眼看不見, EXCEL 卻會分辨
原本字串長度 = Len(原本字串)    '

整理後新字串 = ""               '準備空白的容器, 裝載處理過的字串

i = 0

'找出指定數目的 特殊分隔字符 的位置
For J = 1 To 第X個
i = InStr(i + 1, 原本字串, 特殊分隔字符)    '開始 i = 0, 找到第N個, 位置號碼存在 i, 然後下次從 i+1 開始繼續找
If i = 0 Then Exit For                      '如果完全找不到, 退出
Next

If (i > 0 And 保留動作 = "保存左邊資料") Then
整理後新字串 = Left(原本字串, i - 1)        '如果 i > 0, 表示找到, 把這個分隔符號和後面的資料去掉
End If

If (i > 0 And 保留動作 = "保存右邊資料") Then
整理後新字串 = Mid(原本字串, i + 1)       '如果 i > 0, 表示找到, 把這個分隔符號和前面的資料去掉
End If

分解字串 = 整理後新字串 '返回函數, 處理好的資料

End Function

.
.

REF

http://blog.yahoo.com/xiao-laba/articles/382209