如何获取当前登录用户的邮箱地址？

Question

我是 VBA 新手，正在尝试让自动 Word 文档正常工作。目前，文档中有一个按钮，按下该按钮后，将发出一封附有文档的电子邮件。

但是，我还需要获取发送电子邮件的当前用户的电子邮件地址，以便我可以在发送之前将其放入文档中。我在互联网上的搜索没有找到任何符合我的情况的可用代码。我当前的代码如下。

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)

Set Doc = ActiveDocument
Doc.Save

With EmailItem
    .Subject = "Requesting Authorization Use Overtime"
    .Body = "Please review the following request for overtime" & vbCrLf & _
    "" & vbCrLf & _
    "Thanks"
    .To = "[email protected]"
    .Importance = olImportanceNormal
    .Attachments.Add Doc.FullName
    .Send
End With

不确定这是否相关，但是当使用文档时，Outlook 应用程序将始终在用户登录的情况下打开。我习惯在此类情况下获得智能感知帮助，因此我可以随意使用方法和属性，但智能感知的帮助似乎很少。

Answer 1

这完全取决于“当前用户地址”的定义。

1. Outlook 中主帐户的地址可以从

   Appication.Session.CurrentUser

   检索（返回

   Recipient

   对象）。使用

   Recipient.Address

   属性。但请注意，对于 Exchange 帐户 (

   Recipient.AddressEntry.Type == "EX"

   )，您将收到 EX 类型地址。要检索 SMTP 地址，请使用

   Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress

   。准备好在出现错误时处理空值/异常。这是您在特定情况下最可能需要的。
   
   在扩展 MAPI 级别（C++ 或 Delphi）上，使用

   IMAPISession::QueryIdentity

   （您可以在 OutlookSpy 中测试它（我是其作者） - 单击 IMAPISession 按钮，然后单击 QueryIdentity）。然后，您可以读取

   PR_ADDRTYPE

   属性（“EX”与“SMTP”）和

   PR_EMAIL_ADDRESS

   （当

   PR_ADDRTYPE

   =“SMTP”时）或（如果是 Exchange）

   PR_SMTP_ADDRESS

   （不保证存在）和

   PR_EMS_AB_PROXY_ADDRESSES

   （多值属性将交换地址，包括所有代理（别名）地址）。

2. 如果配置文件中有多个帐户，则可以通过多个帐户发送或接收电子邮件。在这种情况下，请使用

   MailItem.SendUsingAccount

   （返回

   Account

   对象，可以为 null - 在这种情况下使用

   Application.Session.CurentUser

   ）。这对于接收、发送或撰写电子邮件均有效（

   Application.ActiveInspector.CurrentItem

   或

   Application.ActiveExplorer.ActiveInlineResponse

   ）。

3. 给定配置文件中的所有帐户都可以使用

   Namespace.Accounts

   集合

   (Application.Session.Accounts

   ）进行访问。可以使用

   Account.SmtpAddress

   属性访问帐户地址。 请注意，Outlook 对象模型仅公开邮件帐户。某些商店帐户（例如 PST）不在集合中，因为即使某些其他帐户（例如 POP3/SMTP）可以传送到该商店，它们也没有固有的用户身份。如果你想访问所有账户，你可以使用Redemption（我是它的作者）和它的RDOSession.Accounts集合（RDOAccounts对象）。
   在扩展 MAPI 级别，帐户通过 IOlkAccountManager 接口公开。如果您单击 IOlkAccountManager 按钮，您可以在 OutlookSpy 中使用它。

4. 对于委托 Exchange 存储，存储所有者不会通过 Outlook 对象模型公开。您可以使用扩展 MAPI（请注意，

   PR_MAILBOX_OWNER_ENTRYID

   属性仅由在线商店公开，在缓存商店中不可用）。您可以解析 Exchange 存储条目 ID 并从中提取 EX 类型地址。然后，您可以根据给定的 EX 地址构造 GAL 对象条目 id。您还可以使用 Redemption 及其 RDOExchangeMailboxStore 对象及其

   Owner

   属性来访问商店所有者。

Answer 2

通常，电子邮件地址是分配给 Outlook 邮件文件夹的名称。
所以试试这个：

'~~> add these lines to your code
Dim olNS As Outlook.NameSpace
Dim olFol AS Outlook.Folder

Set olNS = OL.GetNamespace("MAPI")
Set olFol = olNS.GetDefaultFolder(olFolderInbox)

MsgBox olFol.Parent.Name '~~> most cases contains the email address

这是假设您正在使用早期绑定并正确设置了对象引用。
访问此类信息的另一种方法是直接使用 Namespace 属性。

MsgBox olNS.Accounts.Item(1).DisplayName '~~> usually email address
MsgBox olNS.Accounts.Item(1).SmtpAddress '~~> email address
MsgBox olNS.Accounts.Item(1).UserName '~~> displays the user name

我希望以上任何内容都能有所帮助。

Answer 3

这个答案适用于后期绑定，因此您不需要参考库。将以下代码放入模块中：

    Dim OL As Object, olAllUsers As Object, oExchUser As Object, oentry As Object, myitem As Object
    Dim User As String

    Set OL = CreateObject("outlook.application")
    Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries

    User = OL.Session.CurrentUser.Name

    Set oentry = olAllUsers.Item(User)

    Set oExchUser = oentry.GetExchangeUser()

    msgbox oExchUser.PrimarySmtpAddress

Answer 4

功能性方法

为了使其更具可重用性，请尝试从函数返回电子邮件。

后期绑定示例

''
' Creates a new instance of Microsoft Outlook to get the current users
' email address.
' Late Binding Demo.
'
' @exception If any errors it will return an optional parameter for fallback values
''
Public Function GetUsersOutlookEmail(Optional ByVal errorFallback As String = "") As String
On Error GoTo catch
    With CreateObject("outlook.application")
        GetUsersOutlookEmail = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Name
    End With
Exit Function
catch:
    GetUsersOutlookEmail = errorFallback
End Function

早期绑定示例

''
' Creates a new instance of Microsoft Outlook to get the current users
' email address.
' Late Binding Demo.
'
' @reference Microsoft Outlook 16.0 Object Reference
' @exception If any errors it will return an optional parameter for fallback values
''
Public Function GetUsersOutlookEmail(Optional ByVal errorFallback As String = "") As String
On Error GoTo catch
    With New Outlook.Application
        GetUsersOutlookEmail = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Name
    End With
Exit Function
catch:
    GetUsersOutlookEmail = errorFallback
End Function

错误处理

任何时候进行这样的 API 调用，总是有可能发生错误。我为这些演示选择的方法是为后备电子邮件提供可选参数。这个 make 是动态的，因为您可以检查它是否为空，或者您可以提供诸如用户名之类的内容

Environ("Username") & "@outlook.com"

Answer 5

试试这个：

Func GetUserEmail()
 
    Dim emailAddress As String

    emailAddress = CreateObject("Outlook.Application").GetNamespace("MAPI").Accounts.Item(1).SmtpAddress

    'Return Users email
    GetUserEmail = emailAddress
 
End Func