我想知道是否可以使用VBA 获取Access 2016 中的当前登录用户，并且他们使用Office 365 帐户？
一点背景知识：我有一个正在运行的 Access 2016 应用程序，它连接到表格的多个 Sharepoint 在线列表。这允许用户进行更新并将记录添加到数据库中，而无需互相干预。虽然要使其正常工作，但他们需要使用 Office 365 登录来访问表格。
我想添加一些表单控件并将某些记录限制为使用 VBA 的某些用户。
问：是否可以将Office 365 用户名传递给VBA 变量或使用环境变量捕获它？
【问题讨论】：
这就是我会做的。将此代码放在“ThisWorkbook”模块中：
'---------------------------------------------------------------------------------------
' Module : ThisWorkbook
' Type : VBA Document
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Module is to <Purpose Here>
'---------------------------------------------------------------------------------------
Option Explicit
Private Sub Workbook_Open()
'---------------------------------------------------------------------------------------
' Procedure : Workbook_Open
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Procedure is to <Purpose Here>
'---------------------------------------------------------------------------------------
'
10 On Error GoTo Workbook_Open_Error
20 [A1] = strMsg
Workbook_Open_Exit:
30 On Error GoTo 0
40 Exit Sub
Workbook_Open_Error:
50 MsgBox "Error " & Err.Number & " on Line # " & Erl & " (" & Err.Description & ") in procedure Workbook_Open of VBA Document ThisWorkbook"
60 GoTo Workbook_Open_Exit
End Sub
然后添加这两个模块，你可以随意命名。
'---------------------------------------------------------------------------------------
' Module : mod_GetOutlookAccounts
' Type : Module
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Module is to <Purpose Here>
'---------------------------------------------------------------------------------------
Option Explicit
Public Const strMsg As String = "CLICK BUTTON BELOW AND GET ALL YOUR ACCOUNT DETAILS HERE FROM OUTLOOK!!" & vbCrLf & _
"" & vbCrLf & _
" Brought to you by Vikram Shankar Mathur " & vbCrLf & _
" (vsmathurco@hotmail.com) " & vbCrLf & _
" +91-9998090111 "
Sub GetOutLookAccounts()
'---------------------------------------------------------------------------------------
' Procedure : GetOutLookAccounts
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Procedure is to <Purpose Here>
'---------------------------------------------------------------------------------------
'
Dim strMsg As String
270 On Error GoTo GetOutLookAccounts_Error
280 strMsg = [A1]
290 [A1] = ReturnOutlookAccounts()
300 MsgBox strMsg, vbInformation, "Call me or email me if you like this!!"
GetOutLookAccounts_Exit:
310 On Error GoTo 0
320 Exit Sub
GetOutLookAccounts_Error:
330 MsgBox "Error " & Err.Number & " on Line # " & Erl & " (" & Err.Description & ") in procedure GetOutLookAccounts of Module mod_GetOutlookAccounts"
340 GoTo GetOutLookAccounts_Exit
End Sub
'---------------------------------------------------------------------------------------
' Module : mod_ReturnOutlookAccounts
' Type : Module
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Module is to <Purpose Here>
'---------------------------------------------------------------------------------------
Option Explicit
Function ReturnOutlookAccounts() As String
'---------------------------------------------------------------------------------------
' Procedure : ReturnOutlookAccounts
' Author : vsmathur-onms
' Date : 29/07/2019
' Purpose : The Purpose of this Procedure is to <Purpose Here>
'---------------------------------------------------------------------------------------
'
Dim NameSpace As Object
Dim Account As Object
Dim strEmailAddress As String
Dim strMessage As String
70 On Error GoTo ReturnOutlookAccounts_Error
80 Set NameSpace = CreateObject("Outlook.Application").GetNameSpace("MAPI")
90 strEmailAddress = ""
100 strMessage = "These were the accounts found in Microsoft Outlook 2016:" & vbCrLf
110 For Each Account In NameSpace.Accounts
' If LCase(Split(Account.SmtpAddress, "@")(1)) = "onmicrosoft.com" Then
120 If InStrRev(Account.SmtpAddress, "@", -1, vbTextCompare) <> 0 Then
130 strEmailAddress = Account.SmtpAddress
140 strMessage = strMessage & vbCrLf & "Email Address=[" & strEmailAddress & "]" & _
" DisplayName=[" & Account.DisplayName & "] Username=[" & Account.UserName & "]" & _
" SMTPAddress=[" & Account.SmtpAddress & "] AcType =[" & Account.AccountType & "]" & _
" CurrentUser=[" & Account.CurrentUser & "]" & vbCrLf
150 Else
160 strEmailAddress = "Unknown"
170 strMessage = strMessage & " ********** Unknown User **********" & vbCrLf
180 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
190 Next
200 ReturnOutlookAccounts = strMessage
ReturnOutlookAccounts_Exit:
210 Set NameSpace = Nothing
220 Set Account = Nothing
230 On Error GoTo 0
240 Exit Function
ReturnOutlookAccounts_Error:
250 MsgBox "Error " & Err.Number & " on Line # " & Erl & " (" & Err.Description & ") in procedure ReturnOutlookAccounts of Module mod_ReturnOutlookAccounts"
260 GoTo ReturnOutlookAccounts_Exit
End Function
【讨论】：
我正在使用 Excel 并找到了一种方法来执行此操作，我只在 Accounts 集合中找到了一个地址，但是有一个后缀匹配来尝试捕获我正在寻找的 @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
【讨论】：