Office 365 username to VBA in Access 2016

Question

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?

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.

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

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

Answer 1

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 1

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

Answer 2

I'm using Excel and found a way to do this, I've only ever found one address in the Accounts collection, but have a suffix match to try and catch the @company.com I'm looking for:

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