テスト95

Sub test()

'Excelで使う場合、以下の参照設定をしておく
'Microsoft  Outlook 16.0 Object Library

'注意点として「連絡先」は個人で使う用のアドレス一覧
'「アドレス帳」は組織で使うアドレス一覧
'業務で特定のアドレスを検索したい場合は、
'通常はアドレス帳から検索する...φ(･ω･*)ﾒﾓﾒﾓ

Dim Addr As String

Addr = "テスト"

If Check_Address(Addr) = False Then

    MsgBox "指定のアドレスが見つかりませんでした。"
    End
    
End If

Stop

End Sub

Public Function Check_Address(ByVal Addr As String) As Boolean

Dim ol As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddressList As AddressList
Dim myAddressEntries As AddressEntries
Dim myAddr As AddressEntry
Dim oExUser As ExchangeUser

Check_Address = False

On Error Resume Next

Set ol = GetObject(, "Outlook.Application")

If ol Is Nothing Then

    Set ol = CreateObject("Outlook.Application")

End If

On Error GoTo 0

'---------------------------------------

Set myNameSpace = ol.GetNamespace("MAPI")
Set myAddressList = myNameSpace.AddressLists("Offline Global Address List")
Set myAddressEntries = myAddressList.AddressEntries

For Each myAddr In myAddressEntries

    Set oExUser = myAddr.GetExchangeUser

    If Not oExUser Is Nothing Then
    
        If oExUser.PrimarySmtpAddress = Addr Then
    
            Debug.Print ("メールアドレス：" & oExUser.PrimarySmtpAddress)
            Check_Address = True
            Exit Function
            
        End If
    
    End If
    
    
Next

End Function