# Getting Windows User Info From The Active Directory

I took some boilerplate code that I have been using for determining an active windows user's info to either send emails with their details, or to pass to a error logging class, and encapsulated it in its own class.

What I would like to know about my implementation of this is: Are there more efficient ways of doing this over using ADO to query the directory, and should ActiveWindowsSession be made accessible as a Predclared Class?

The reason I ask about making it Predclared is, the active user is static as is their info, so I would think that a static implementation would be more suitable, but I am not sure.

Class: ActiveWindowsSession

Option Explicit

Private Const CONNECTION_STRING As String = "ADsDSOObject"
Private Const CONNECTION_PROVIDER As String = "Active Directory Provider"

Private Type TActiveWindowsSession
UserDisplayName As String
UserFirstName As String
UserLastName As String
UserCommonName As String
UserTelephoneNumber As String
UserDepartment As String
CompanySiteName As String
DomainName As String
MachineName As String
WindowsVerion As String
AppVersion As String
End Type

Private this As TActiveWindowsSession

Private Sub Class_Initialize()
GetUserAttributes
GetSystemAttributes
End Sub

Private Sub Class_Terminate()
With this
.UserDisplayName = Empty
.UserFirstName = Empty
.UserLastName = Empty
.UserCommonName = Empty
.UserTelephoneNumber = Empty
.UserDepartment = Empty
.CompanySiteName = Empty
.DomainName = Empty
.MachineName = Empty
.WindowsVerion = Empty
.AppVersion = Empty
End With
End Sub

Public Property Get UserName() As String
End Property

Public Property Get UserDisplayName() As String
UserDisplayName = this.UserDisplayName
End Property

Public Property Get UserFirstName() As String
UserFirstName = this.UserFirstName
End Property

Public Property Get UserLastName() As String
UserLastName = this.UserLastName
End Property

Public Property Get UserCommonName() As String
UserCommonName = this.UserCommonName
End Property

Public Property Get UserEmailAddress() As String
End Property

Public Property Get UserDepartment() As String
UserDepartment = this.UserDepartment
End Property

Public Property Get UserTelephoneNumber() As String
UserTelephoneNumber = this.UserTelephoneNumber
End Property

Public Property Get CompanySiteName() As String
CompanySiteName = this.CompanySiteName
End Property

Public Property Get DomainName() As String
DomainName = this.DomainName
End Property

Public Property Get MachineName() As String
MachineName = this.MachineName
End Property

Public Property Get WindowsVerion() As String
WindowsVerion = this.WindowsVerion
End Property

Public Property Get AppVersion() As String
AppVersion = this.AppVersion
End Property

Private Sub GetUserAttributes()

Dim Conn As Object, Cmnd As Object, Rcrdset As Object
Dim rootDSE As Object
Dim Base As String, Filter As String, _
UserAttributes As String
Const Scope As String = "subtree"

this.UserName = VBA.Environ$("Username") On Error GoTo CleanFail Set rootDSE = GetObject("LDAP://RootDSE") Base = "<LDAP://" & rootDSE.Get("defaultNamingContext") & ">" 'filter on user objects with the given account name Filter = "(&(objectClass=user)(objectCategory=Person)" Filter = Filter & "(sAMAccountName=" & this.UserName & "))" UserAttributes = "physicalDeliveryOfficeName,department,displayName," & _ "givenName,sn,mail,telephoneNumber" Set Conn = CreateObject("ADODB.Connection") Conn.Provider = CONNECTION_STRING Conn.Open CONNECTION_PROVIDER Set Cmnd = CreateObject("ADODB.Command") Set Cmnd.ActiveConnection = Conn Cmnd.CommandText = Base & ";" & Filter & ";" _ & UserAttributes & ";" & Scope Set Rcrdset = Cmnd.Execute If Rcrdset.EOF Then GoTo CleanExit 'at times, some of these fields aren't supported so 'so I am usesing on error resume next to avoid any errors 'thrown by and empty field value On Error Resume Next With this .CompanySiteName = Rcrdset.Fields("physicalDeliveryOfficeName").value .UserDepartment = Rcrdset.Fields("department").value .UserDisplayName = Rcrdset.Fields("displayName").value .UserFirstName = Rcrdset.Fields("givenName").value .UserLastName = Rcrdset.Fields("sn").value .UserCommonName = Trim$(.UserFirstName & " " & .UserLastName)
.UserTelephoneNumber = Rcrdset.Fields("telephoneNumber").value
End With

CleanExit:
Exit Sub

CleanFail:
Resume CleanExit

End Sub

Private Sub GetSystemAttributes()
With this
.DomainName = LCase$(Environ$("USERDNSDOMAIN"))
.MachineName = Environ$("COMPUTERNAME") .WindowsVerion = Application.OperatingSystem .AppVersion = Application.Version End With End Sub Public Sub PrintToImmediateWindow() With this Debug.Print "Windows Verion: "; Tab(20); .WindowsVerion Debug.Print "App Version: "; Tab(20); .AppVersion Debug.Print "Machine Name: "; Tab(20); .MachineName Debug.Print "Site Name: "; Tab(20); .CompanySiteName Debug.Print "Domain DNS Name: "; Tab(20); .DomainName Debug.Print "User Name: "; Tab(20); .UserName Debug.Print "Display Name: "; Tab(20); .UserDisplayName Debug.Print "First Name: "; Tab(20); .UserFirstName Debug.Print "Last Name: "; Tab(20); .UserLastName Debug.Print "Common Name: "; Tab(20); .UserCommonName Debug.Print "Email Address: "; Tab(20); .UserEmailAddress End With End Sub Private Sub CleanUpADODBObjects(ByRef ConnectionIn As Object, ByRef RecordsetIn As Object) 'bit-wise comparison If Not ConnectionIn Is Nothing Then If (ConnectionIn.State And ADODB_OBJECT_STATE) = ADODB_OBJECT_STATE Then ConnectionIn.Close End If End If Set ConnectionIn = Nothing If Not RecordsetIn Is Nothing Then If (RecordsetIn.State And ADODB_OBJECT_STATE) = ADODB_OBJECT_STATE Then RecordsetIn.Close End If End If Set RecordsetIn = Nothing End Sub  Usage: Sub TestingWindowsSession() Dim WinSession As ActiveWindowsSession Set WinSession = New ActiveWindowsSession WinSession.PrintToImmediateWindow End Sub  The immediate window: ## 1 Answer Very clean code, reads very nicely, well done! Watch for inconsistencies in indentation: Public Sub PrintToImmediateWindow() With this  Private Sub GetSystemAttributes() With this  Rubberduck can fix that for you (across the entire project) with a single click. Consistent indentation is normally understood as "executable statements within a code block are all lined up". I don't see code blocks here, and yet I'm looking at 3 levels of indentation:  Const Scope As String = "subtree" this.UserName = VBA.Environ$("Username")

On Error GoTo CleanFail
Set rootDSE = GetObject("LDAP://RootDSE")

Base = "<LDAP://" & rootDSE.Get("defaultNamingContext") & ">"


That's distracting.

So is having a block of declarations at the top of a procedure scope, and/or having multiple declarations in a single instruction:

Dim Conn As Object, Cmnd As Object, Rcrdset As Object
Dim rootDSE As Object
Dim Base As String, Filter As String, _
UserAttributes As String


Of particular note, the line-continuated UserAttributes makes me wonder why that one had to be on its own line (while still being part of the previous Dim statement): I shouldn't have to ask myself these questions when reading code. Also disemvoweling (removing random vowels) should not be needed.

Dim Conn As Object, Cmnd As Object, Rcrdset As Object


I'm not a zealot, so to me Dim db As Object, Dim cmd As Object, and Dim rs As Object would be fine (as long as the declarations are right next to where they're set, so there's more context to it than just "well it's an object"), but Rcrdset is extremely typo-prone (kudos for Option Explicit to pick that up!).

Contrast to how seamless reading becomes, if declarations are right where they're relevant:

Dim rootDSE As Object
Set rootDSE = GetObject("LDAP://RootDSE")

Dim base As String '<~ casing
base = "<LDAP://" & rootDSE.Get("defaultNamingContext") & ">"

Dim filter As String '<~ casing
filter = "(&(objectClass=user)(objectCategory=Person)"

'..

Dim conn As Object '<~ casing


I know this is harder to do in a case-insensitive language, but using PascalCase for some local variables, and camelCase for others, is also inconsistent and distracting, readability-wise.

    'at times, some of these fields aren't supported so
'so I am usesing on error resume next to avoid any errors
'thrown by and empty field value
On Error Resume Next
With this
.CompanySiteName = Rcrdset.Fields("physicalDeliveryOfficeName").value
.UserDepartment = Rcrdset.Fields("department").value
.UserDisplayName = Rcrdset.Fields("displayName").value
.UserFirstName = Rcrdset.Fields("givenName").value
.UserLastName = Rcrdset.Fields("sn").value
.UserCommonName = Trim\$(.UserFirstName & " " & .UserLastName)
.UserTelephoneNumber = Rcrdset.Fields("telephoneNumber").value
End With


It's not wrong, but it's not ideal either. Consider extracting the OERN into its own reduced scope:

Private Function GetFieldValueOrDefault(ByVal rs As Recordset, ByVal fieldName As String) As Variant
On Error Resume Next
GetFieldValueOrDefault = rs.Fields(fieldName).Value
On Error GoTo 0
End Function


There's a bunch of implicit conversions happening here:

Private Sub Class_Terminate()
With this
.UserDisplayName = Empty
.UserFirstName = Empty
.UserLastName = Empty
.UserCommonName = Empty
.UserTelephoneNumber = Empty
.UserDepartment = Empty
.CompanySiteName = Empty
.DomainName = Empty
.MachineName = Empty
.WindowsVerion = Empty
.AppVersion = Empty
End With
End Sub


Empty is a special type in VBA, that works with Variant: vbEmpty would be the constant for it, but then if you assign vbEmpty to a String value, you're implicitly converting Variant/Empty to String, and so the value that ends up being assigned is "" - note that the implicit conversion is making an implicit allocation; the value of StrPtr(Empty) will be different for every single call - meanwhile the value of StrPtr(vbNullString) is 0, i.e. using = vbNullString instead of = Empty would remove the implicit conversions and the intermediate memory allocations.

I'm not sure what to think of CleanUpADODBObjects: on one hand I can appreciate taking that concern out of the calling procedure, on the other I can't help but wave a red flag when an object is being destroyed in another scope than the scope it was created in. This could be because GetUserAttributes is responsible for too many things. Also, an error in that scope can result in an infinite loop:

CleanExit:
CleanUpADODBObjects Conn, Rcrdset '<~ raises an error, goto cleanfail
Exit Sub

CleanFail:
Resume CleanExit '<~ ok, but if CleanUpADODBObjects raises an error...

• Why you you would clear a variable in Class_Terminate? – TinMan Oct 11 '19 at 21:43
• @TinMan Good point: I wouldn't - at least not for a String (or any other kind of non-problematic reference) value – Mathieu Guindon Oct 11 '19 at 21:45
• Hmm... that the t as TypeA had object field, newT as TypA : t = NewT should still reset all the fields. Correct? Better question, when a Open ADODB.Connection fails out of scope is it automatically closed? Is there a why to test the number of open ADODB.Connections? – TinMan Oct 11 '19 at 21:55
• Client-side, I would think if the object falls out of scope, it's destroyed (and yes, closed)... but bugs in the implementation can keep this from happening. I'd monitor connections server-side, see if they're left lingering, and adjust accordingly. In any case I wouldn't Set foo = Nothing explicitly without a solid reason to do so (and a comment explaining why it's needed). – Mathieu Guindon Oct 11 '19 at 22:02
• I never gave much thought to bugs in the implementation, makes sense. I know that I have been victimized by them in the past. Rem No foo for you ..seems appropriate Thanks for your time. – TinMan Oct 11 '19 at 22:13