Office 365 用户名到 Access 2016 中的 VBA [英] Office 365 username to VBA in Access 2016

问题描述

我想知道是否可以使用 VBA 在 Access 2016 中获取当前登录的用户，他们使用 Office 365帐户?

I was wondering if it's possible to use VBA to get the current logged in user in Access 2016, with them using an Office 365 account?

背景知识:我有一个 Access 2016 应用程序正在运行，该应用程序连接到表格的多个 Sharepoint 在线列表.这允许用户进行更新并将记录添加到数据库中，而不会相互影响.尽管要使其正常工作，他们需要使用 Office 365 登录名登录才能访问表格.

A bit of background: I have an Access 2016 app that's running that connects to multiple Sharepoint online lists for the tables. This allows users to make updates and add records to the DB without stepping on each other's toes. Though for this to work they need to log in using their Office 365 login to access the tables.

我想添加一些表单控件并将某些记录限制为使用 VBA 的某些用户.

I want to add some form controls and restrict certain records to certain users using VBA.

问:是否可以将 Office 365 用户名传递到 VBA 变量或使用环境变量捕获它?

Q: Is it possible to pass the Office 365 username into a VBA variable or capture it using an environmental variable?

推荐答案

这就是我的做法.将此代码放在ThisWorkbook"模块中:

This is how I would have done it. Put this code in the "ThisWorkbook" module:

'---------------------------------------------------------------------------------------
' 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

然后添加这两个模块，你可以随意命名它们.

And then add these two modules, you can name them what you want.

'---------------------------------------------------------------------------------------
' 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 & _
                                "                    ([e-mail])                           " & vbCrLf & _
                                "                         [phone]                                "

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

模块 2

'---------------------------------------------------------------------------------------
' 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

这篇关于Office 365 用户名到 Access 2016 中的 VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！