Word and Excel provide native VBA methods to retrieve
the UserName (not to be confused with the User login name). PowerPoint
provides no such method. The User Information is stored in the registry
as unicode values which can be accessed by reading the registry. This
generic wrapper class encapsulates the retrieval process. It can
be used to read the Username (not available in PowerPoint), UserInitials
(not available in PowerPoint & Excel) & Company name (not
available in any of the mentioned products).
Note: The code has been set for Office 2000, When
running under Office 97 set the appropriate value for the variable KeyName
' --------------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
'
--------------------------------------------------------------------------------
'Class Module - UserInfo
'Local variable(s)
Private sUserName As String
Private sUserInitials As String
Private sCompany As String
Const KEY_ALL_ACCESS = &H2003F
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_SUCCESS = 0
' API declares to read the registry
Private Declare Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
ByRef lpType As Long, _
ByVal lpData As String, _
ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" _
(ByVal hKey As Long) As Long
Public Property Get Company() As String
Company = sCompany
End Property
Public Property Get UserInitials() As String
UserInitials = sUserInitials
End Property
Public Property Get UserName() As String
UserName = sUserName
End Property
Private Function GetKeyValue(SubKeyRef As String, _
ByRef KeyVal As String) As Boolean
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open Registry Key
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry Key Variable
Dim KeyValType As Long
Dim KeyName As String
KeyName = "Software\Microsoft\Office\" & Application.Version & "\Common\UserInfo"
'Open RegKey Under KeyRoot {HKEY_CURRENT_USER...}
rc = RegOpenKeyEx(HKEY_CURRENT_USER, KeyName, 0, _
KEY_ALL_ACCESS, hKey)
' Handle Error...
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError
' Allocate Variable Space
tmpVal = String$(1024, 0)
' Mark Variable Size
KeyValSize = 1024
' Retrieve Registry Key Value...
rc = RegQueryValueEx(hKey, SubKeyRef, _
0, KeyValType, tmpVal, _
KeyValSize)
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError
'Convert from a unicode value
KeyVal = StrConv(tmpVal, vbFromUnicode)
GetKeyValue = True ' Return Success
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function
' Cleanup After An Error Has Occured...
GetKeyError:
KeyVal = "" ' Set Return Val To Empty String
GetKeyValue = False ' Return Failure
rc = RegCloseKey(hKey)
End Function
Private Sub Class_Initialize()
Call ReadUserInfo
End Sub
Sub ReadUserInfo()
Call GetKeyValue("Company", sCompany)
Call GetKeyValue("UserName", sUserName)
Call GetKeyValue("UserInitials", sUserInitials)
End Sub
' Code Module
Sub ShowUserInfo()
Dim UserDetails As New UserInfo
With UserDetails
Debug.Print .UserName
Debug.Print .UserInitials
Debug.Print .Company
End With
End Sub
|