'=========================================================
'* 指定メールアドレスがアドレス帳で名前解決できるか判定する関数
'* 引数:
'* sEmail: 判定対象のメールアドレス (String)
'* 戻り値:
'* True : アドレス帳に存在し、名前解決可能
'* False : 存在しない、または名前解決できない
'=========================================================
Public Function IsAddressInAddressBook(ByVal sEmail As String) As Boolean
Dim oOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oRecip As Outlook.Recipient
On Error GoTo ErrHandler
IsAddressInAddressBook = False ' デフォルトは False
sEmail = Trim$(sEmail)
If Len(sEmail) = 0 Then Exit Function
' Outlook アプリケーション取得
Set oOutlook = Application ' Outlook VBA想定
' テスト用メールアイテム作成
Set oMail = oOutlook.CreateItem(olMailItem)
oMail.To = sEmail
' アドレス帳で名前解決
If Not oMail.Recipients.ResolveAll Then
GoTo Cleanup ' 解決できなければ False のまま終了
End If
Set oRecip = oMail.Recipients.Item(1)
If oRecip Is Nothing Then GoTo Cleanup
' oRecip.Name が空でなく、かつメールアドレスと異なる場合を「存在」と判定
If oRecip.Name <> "" And oRecip.Name <> sEmail Then
IsAddressInAddressBook = True
Else
' oRecip.Name = sEmail または "" の場合は解決できていないとみなす
IsAddressInAddressBook = False
End If
Cleanup:
On Error Resume Next
If Not oMail Is Nothing Then
oMail.Close olDiscard
End If
Set oRecip = Nothing
Set oMail = Nothing
Set oOutlook = Nothing
Exit Function
ErrHandler:
' 何か例外が出たら False のまま終了
IsAddressInAddressBook = False
Resume Cleanup
End Function
