Environ ("USERNAME") in VBA returns "User" after updating Windows 8

Question

I have an Access database that needs to validate a username with Environ("USERNAME").
Although this works for my users who use Win7, I recently upgraded to Win8 and the code returns the text “User” on my laptop. I also tried CreateObject("WScript.Network").Usernamewith the same result.

• Is this a thing for Windows 8 and will I have a problem updating other users?
• Is there any way to change / customize this user text? My laptop is not connected to the corporate network that other users use, so it may turn out that when upgrading to Win8 their laptops will return the correct network username.

Answer 1

I would use this call to the Windows API:

    Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
                    (ByVal lpBuffer As String, nSize As Long) As Long

    Public Function GetWindowsUserName() As String
        Dim strUserName As String
        strUserName = String(100, Chr$(0))
        GetUserName strUserName, 100
        GetWindowsUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
    End Function

Answer 2

You must do this using a WMI request.

Function GetFullName() As String
    Dim computer As String
    computer = "."

    Dim objWMIService, colProcessList As Object
    Set objWMIService = GetObject("winmgmts:\\" & computer & "\root\cimv2")
    Set colProcessList = objWMIService.ExecQuery _
        ("SELECT TOP 1 * FROM Win32_Process WHERE Name = 'ACCESS.EXE'")

    Dim uname, udomain As String
    Dim objProcess As Object
    For Each objProcess In colProcessList
        objProcess.GetOwner uname, udomain
    Next
    GetFullName = UCase(udomain) & "\" & UCase(uname)
End Function

If you don’t need context, just delete “UCase (udomain)" and "\" & "

Answer 3

. , , , . , 8, . "GetFullNameOfLoggedUser()"
, ! , , , - , , !

Private Type ExtendedUserInfo
    EUI_name As Long
    EUI_password  As Long ' Null, only settable
    EUI_password_age  As Long
    EUI_priv  As Long
    EUI_home_dir  As Long
    EUI_comment  As Long
    EUI_flags  As Long
    EUI_script_path  As Long
    EUI_auth_flags  As Long
    EUI_full_name As Long
    EUI_usr_comment  As Long
    EUI_parms  As Long
    EUI_workstations  As Long
    EUI_last_logon  As Long
    EUI_last_logoff  As Long
    EUI_acct_expires  As Long
    EUI_max_storage  As Long
    EUI_units_per_week  As Long
    EUI_logon_hours  As Long
    EUI_bad_pw_count  As Long
    EUI_num_logons  As Long
    EUI_logon_server  As Long
    EUI_country_code  As Long
    EUI_code_page  As Long
End Type

 'Windows API function declarations
Private Declare Function apiNetGetDCName Lib "netapi32.dll" _
Alias "NetGetDCName" (ByVal servername As Long, _
ByVal DomainName As Long, _
bufptr As Long) As Long

 ' function frees the memory that the NetApiBufferAllocate function allocates.
Private Declare Function apiNetAPIBufferFree Lib "netapi32.dll" _
Alias "NetApiBufferFree" (ByVal buffer As Long) As Long

 ' Retrieves the length of the specified Unicode string.
Private Declare Function apilstrlenW Lib "kernel32" _
Alias "lstrlenW" (ByVal lpString As Long) As Long

Private Declare Function apiNetUserGetInfo Lib "netapi32.dll" _
Alias "NetUserGetInfo" (servername As Any, _
username As Any, _
ByVal level As Long, _
bufptr As Long) As Long

 ' moves memory either forward or backward, aligned or unaligned,
 ' in 4-byte blocks, followed by any remaining bytes
Private Declare Sub sapiCopyMem Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)

Private Declare Function apiGetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&

Function GetFullNameOfLoggedUser(Optional strUserName As String) As String
     '
     ' Returns the full name for a given network username (NT/2000/XP only)
     ' Omitting the argument will retrieve the full name for the currently logged on   user
     '
    On Error GoTo Err_GetFullNameOfLoggedUser
    Dim pBuf As Long
    Dim dwRec As Long
    Dim pTmp As ExtendedUserInfo
    Dim abytPDCName() As Byte
    Dim abytUserName() As Byte
    Dim lngRet As Long
    Dim i As Long

     ' Unicode
    abytPDCName = GetDCName() & vbNullChar
    If (Len(strUserName) = 0) Then
        strUserName = GetUserName()
    End If
    abytUserName = strUserName & vbNullChar

     ' Level 2
    lngRet = apiNetUserGetInfo(abytPDCName(0), abytUserName(0), 2, pBuf)
    If (lngRet = ERROR_SUCCESS) Then
        Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
        GetFullNameOfLoggedUser = StrFromPtrW(pTmp.EUI_full_name)
        gvusername = abytUserName
    End If

    Call apiNetAPIBufferFree(pBuf)

Exit_GetFullNameOfLoggedUser:
    Exit Function

Err_GetFullNameOfLoggedUser:
    MsgBox Err.Description, vbExclamation
    GetFullNameOfLoggedUser = vbNullString
    Resume Exit_GetFullNameOfLoggedUser
End Function

Private Function GetUserName() As String
     ' Returns the network login name
    Dim lngLen As Long, lngRet As Long
    Dim strUserName As String
    strUserName = String$(254, 0)
    lngLen = 255
    lngRet = apiGetUserName(strUserName, lngLen)
    If lngRet Then
        GetUserName = Left$(strUserName, lngLen - 1)
    End If
End Function

Function GetDCName() As String
    Dim pTmp As Long
    Dim lngRet As Long
    Dim abytBuf() As Byte

    lngRet = apiNetGetDCName(0, 0, pTmp)
    If lngRet = NERR_SUCCESS Then
        GetDCName = StrFromPtrW(pTmp)
    End If
    Call apiNetAPIBufferFree(pTmp)
End Function

Private Function StrFromPtrW(pBuf As Long) As String
    Dim lngLen As Long
    Dim abytBuf() As Byte

     ' Get the length of the string at the memory location
    lngLen = apilstrlenW(pBuf) * 2
     ' if it not a ZLS
    If lngLen Then
        ReDim abytBuf(lngLen)
         ' then copy the memory contents
         ' into a temp buffer
        Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen)
         ' return the buffer
        StrFromPtrW = abytBuf
    End If
End Function