Display Excel account username in a cell on open - vba

Question

Working with Office 2013, I am trying to insert VBA code to automatically enter the employee name as it is displayed in the top right hand corner of any Office product into cell B2 upon them opening up the excel spreadsheet. The current code I am using is
Sub Auto_Open()
Range("B2").Value = " " & Application.UserName
End Sub
However, this just makes it display "Authorized User".
What am I doing wrong?

Answer 1

I poked around at this morning. I figured this information must be stored somewhere in the registry if it isn't accessible as part of the Excel object model. This makes sense, especially if this username is part of a corporate subscription.
The Registry Key
I did a search in the registry for how my username showed up in Excel, and this popped up.
The FriendlyName is exactly how my username shows up in Excel. So all we need now is a method to read this registry key's FriendlyName, and that should do it :)
Code
Here is some code that works for me based on the location of this key. It may be slightly different on your computer, so you may need to tweak this to find the FriendlyName
Private Function GetFriendlyName() As String
On Error GoTo ErrorHandler:
Const HKEY_CURRENT_USER = &H80000001
Const ComputerName As String = "."
Dim CPU As Object
Dim RegistryKeyPath As String
Dim RegistrySubKeys() As Variant
Dim RegistryValues() As Variant
Dim SubKeyName As Variant
Dim SubKeyValue As Variant
Dim KeyPath As String
GetFriendlyName = vbNullString
Set CPU = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\default:StdRegProv")
'Specify where to look
RegistryKeyPath = "Software\Microsoft\Office\" & Application.Version & "\Common\Identity\Identities"
'Enumerate the registry keys
CPU.EnumKey HKEY_CURRENT_USER, RegistryKeyPath, RegistrySubKeys
'Iterate each key in the identities folder
For Each SubKeyName In RegistrySubKeys
'Get each value in that folder
CPU.EnumValues HKEY_CURRENT_USER, RegistryKeyPath & "\" & SubKeyName, RegistryValues
'Go through each value, and find the Friendly Name
For Each SubKeyValue In RegistryValues
If SubKeyValue = "FriendlyName" Then
KeyPath = "HKEY_CURRENT_USER\" & RegistryKeyPath & "\" & SubKeyName & "\" & SubKeyValue
'Read the key
With CreateObject("Wscript.Shell")
GetFriendlyName = .RegRead(KeyPath)
End With
Exit Function
End If
Next
Next
CleanExit:
Exit Function
ErrorHandler:
'Handle errors here
Resume CleanExit
End Function
'Run this to see the output in the immediate window
Private Sub ExampleUsage()
Debug.Print "The friendly name is: " & GetFriendlyName
End Sub
Results
The friendly name is: Ryan A. Wildry

Answer 2

Try this:
Sub Auto_Open()
Dim Username As String
Dim path As String
Dim sourcefile As String
Dim objFso As FileSystemObject
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(path & " ~$" & sourcefile) Then
Username = Split(GetFileOwner(path, " ~$" & sourcefile), "\")(1)
Range("B2").Value = " " & Username
Else
MsgBox ("File not Found!")
End If
End Sub