Как я могу получить текущую электронную почту учетной записи Office Windows, используя VBA?

Question

Как я могу получить текущую электронную почту учетной записи Office Windows, используя код VBA? Я не имею в виду учетную запись, которую пользователь вошел в Windows, я имею в виду учетную запись, которая авторизована в офисе

Смотрите изображение:

Answer 1

Я не верю, что вы можете получить к нему доступ. Лучше всего связать Access с Outlook и попытаться получить к нему доступ оттуда.

Например, вы устанавливаете ссылку на библиотеку объектов Outlook, а затем:

Dim olook As Outlook.Application
Dim EAddress As String

Set olook = GetObject(, "Outlook.Application")
Set olook = CreateObject("Outlook.Application")


EAddress = olook.Session.CurrentUser.Address

Answer 2

У меня есть похожее решение для Outlook, я использую Excel и нашел способ сделать это, я только когда-либо нашел один адрес в коллекции учетных записей, но у меня есть суффикс совпадения, чтобы попытаться поймать @company.com Я ищу:

Dim NameSpace As Object
Dim strEmailAddress As String
Set NameSpace = CreateObject("Outlook.Application").GetNameSpace("MAPI")
strEmailAddress = ""

For Each Account In NameSpace.Accounts
    If LCase(Split(Account.SMtpAddress, "@")(1)) = "contoso.com" Then
        strEmailAddress = Account.SMtpAddress
    Else
        strEmailAddress = "Unknown"
    End If

    ' If you want to see more values, uncomment these lines
    'Debug.Print Account.DisplayName
    'Debug.Print Account.UserName
    'Debug.Print Account.SMtpAddress
    'Debug.Print Account.AccountType
    'Debug.Print Account.CurrentUser
Next

Answer 3

Outlook прерывает VBA-выполнение (для доступа к объектам Outlook из макроса) из-за безопасности.

Снимок безопасности Outlook

Следовательно, только для получения eMailID без открытия объекта, а также обработки ошибки в случае отсутствия outlook / account, следующий код может работать в вашем случае

Код VBA

Sub Email_Address()
    Dim MAPI As Object

    Status = "unknown"

    On Error GoTo return_value
    Set MAPI = CreateObject("Outlook.Application").GetNameSpace("MAPI")

    i = 1
    Do While True
        Debug.Print MAPI.Accounts.Item(i)
        i = i + 1
    Loop

return_value:
    If i > 1 Then: Status = "done..."
    Debug.Print Status
End Sub