Getting Windows User Info From The Active Directory

Question

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 Const ADODB_OBJECT_STATE As Integer = 1     'the adStateOpen constant's value


Private Type TActiveWindowsSession
    UserName As String
    UserDisplayName As String
    UserFirstName As String
    UserLastName As String
    UserCommonName As String
    UserEmailAddress 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
        .UserName = Empty
        .UserDisplayName = Empty
        .UserFirstName = Empty
        .UserLastName = Empty
        .UserCommonName = Empty
        .UserEmailAddress = 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
    UserName = this.UserName
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
    UserEmailAddress = this.UserEmailAddress
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
    Dim UserName 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)
            .UserEmailAddress = Rcrdset.Fields("mail").value
            .UserTelephoneNumber = Rcrdset.Fields("telephoneNumber").value
        End With

CleanExit:
    CleanUpADODBObjects Conn, Rcrdset
    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:

Answer 1

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
Dim UserName 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
Set conn = CreateObject("ADODB.Connection")

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.

A note about this:

    '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)
        .UserEmailAddress = Rcrdset.Fields("mail").value
        .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
        .UserName = Empty
        .UserDisplayName = Empty
        .UserFirstName = Empty
        .UserLastName = Empty
        .UserCommonName = Empty
        .UserEmailAddress = 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...