Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7全般 : Excel 2016)
ExcelVBAからOUTLOOKのExchange グローバルアドレス一覧を検索するコード
投稿日時: 19/05/28 20:52:31
投稿者: nontano

ExcelシートA列に入力したメールアドレスををキーとしてExchange グローバルアドレス一覧を検索、
戻り値としてB列に名前、C列に部署を記載するコードをご教示頂けないでしょうか?
 
参考情報を調べると該当するサイトは出てくるのですが、イマイチ内容が理解できませんでした。。
 ※Outlook のバージョンも2016になります。
 
どうぞよろしくお願い致します。

回答
投稿日時: 19/05/29 14:21:24
投稿者: きぬあさ
投稿者のウェブサイトに移動

こんにちは。
 
OutlookのNameSpace.GetGlobalAddressListメソッドでグローバルアドレス一覧を表すAddressListオブジェクトを取得できるので、そこから順番にメールアドレスまで辿って処理すれば良いかと思います。
 
下記は処理の一例です。
 
1.GetGlobalAddressListメソッドでグローバルアドレス一覧を表すAddressListオブジェクトを取得。
2.AddressEntriesプロパティからAddressEntries(コレクション)オブジェクトを取得。
3.For Each文で順次AddressEntryオブジェクトを取得。
4.AddressEntryUserTypeプロパティがolExchangeUserAddressEntryであるかを判断。
5.GetExchangeUserメソッドでExchangeUserオブジェクトを取得。
6.PrimarySmtpAddressプロパティが指定したメールアドレスかどうかを判断。
7.一致した場合ExchangeUserオブジェクトを返す。
 

Option Explicit

Public Sub Sample()
  Dim olApp As Object
  Dim eu As Object 'Outlook.ExchangeUser
  
  On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
  Set eu = GetExchangeUser(olApp, "(メールアドレス)")
  If Not eu Is Nothing Then
    Debug.Print "名前:" & eu.Name & ", 部署名:" & eu.Department & ", メールアドレス:" & eu.PrimarySmtpAddress
  End If
End Sub

Private Function GetExchangeUser(ByVal olApp As Object, _
                                 ByVal SmtpAddress As String) As Object 'Outlook.ExchangeUser
'メールアドレスからOutlook.ExchangeUserオブジェクトを取得
  Dim myList As Object 'Outlook.AddressList
  Dim ae As Object     'Outlook.AddressEntry
  Dim eu As Object     'Outlook.ExchangeUser
  Dim ret As Object    'Outlook.ExchangeUser
  Const olExchangeUserAddressEntry = 0
  
  Set myList = olApp.Session.GetGlobalAddressList
  For Each ae In myList.AddressEntries
    If ae.AddressEntryUserType = olExchangeUserAddressEntry Then
      Set eu = ae.GetExchangeUser
      If eu.PrimarySmtpAddress = SmtpAddress Then
        Set ret = eu
        Exit For
      End If
    End If
  Next
  Set GetExchangeUser = ret
End Function

投稿日時: 19/05/29 23:38:25
投稿者: nontano

きぬあさ さん
こんにちは。
 
ご返信ありがとうございます。
まさにこういう処理をしたかったです。
 
また、処理の解説まで丁寧に書いて頂きありがとうございました。
処理だけでなく、コードの書き方についても大変勉強になりました。
 
ひとまず、頂きましたコードを自分なりに理解し工夫してみようと思います。
 
1点お聞きしたいのですが、
コードの処理時間が長いのは仕方がない事なのでしょうか?
数百行のアドレスを連続で処理したいという希望があるためお聞きさせて頂いています。
 
元々は↓のコードで検討をしており、処理速度の方は問題なかったのですが
部署名の情報がどうしても欲しかったので今回Exchengeで取得する方法を調べてた次第です。
 

Sub subRecipientResolve()
    Dim myMailItem As Outlook.MailItem
    Dim myRecipient As Outlook.Recipient
    Dim lastRow As Integer                  '検索列のデータ最終行
    Dim i As Integer                        '検索列のループ用変数
    
    Const strCol As Long = 1                '検索列の指定
    Const endCol As Long = 2                '結果表示列の指定
    Const firstRow As Long = 2              '検索列のデータ開始行
    
    ThisWorkbook.Sheets("Sheet1").Activate
    lastRow = Cells(Rows.Count, strCol).End(xlUp).Row
    Set myMailItem = Outlook.Application.CreateItem(olMailItem)
    
    For i = firstRow To lastRow
        Dim addCheck As Boolean 'add
    
        Set myRecipient = myMailItem.Recipients.Add(Cells(i, strCol).Value)
        myRecipient.Resolve
        
        If myRecipient.Resolved Then
            Cells(i, endCol).Value = myRecipient
            addCheck = checkEmailAddress(Cells(i, endCol))    'add
            If addCheck Then Cells(i, endCol).Value = "Not-Exist"
        Else
            Cells(i, endCol).Value = "Not-Address"
        End If
 
    Next i
    
    Set myMailItem = Nothing
End Sub

Function checkEmailAddress(addr As String) As Boolean
    If InStr(addr, "@example.co.jp") Then
        checkEmailAddress = True
    Else
        checkEmailAddress = False
    End If
End Function

 
よろしくお願い致します。

回答
投稿日時: 19/05/31 13:09:41
投稿者: きぬあさ
投稿者のウェブサイトに移動

こんにちは。
 

引用:
コードの処理時間が長いのは仕方がない事なのでしょうか?

サーバーを見に行っている分処理に時間が掛かるのはある程度仕方ないのですが、例えば、
 
For Eachで順次AddressEntryオブジェクトを取得→ExchangeUserオブジェクトから部署名等の情報を取得
 
上記結果を作業用のシートか何かに保存しておき、そこからメールアドレスをキーに必要な情報を取得するようにすれば、サーバーを見に行く回数が一度だけで済むので、処理速度は上がるだろうと思います。

トピックに返信