Categories
Excel

Excel – LDAP authentication

The beauty of Excel is the ubiquitousness of the program or support for the file formats. When adding business logic and power to these tools however it can be necessary to restrict access due to company confidential information.

Trying to accomplish this in Excel using VBA is basicly a curse due to the horrible developer environment, lack of debugging, and a fractured reference resource.

While with any programming process there are many ways to accomplish the goal and this is just one.

Assuming a userform that prompts for username and password it will add the domain name if necessary.


 

Const ADS_SECURE_AUTHENTICATION = 1

Const ADS_USE_SSL = 2

 

Dim conn As New ADODB.Connection

Dim rs As ADODB.RecordSet

Dim oRoot As Object

Dim oDomain As Object

Dim sBase As String

Dim sFilter As String

Dim sDomain As String

 

Dim sAttribs As String

Dim sDepth As String

Dim sQuery As String

Dim usern As String

 

 

On Error GoTo ErrHandler:

 

Set oRoot = GetObject(“LDAP://rootDSE”)

 

‘work in the default domain

sDomain = oRoot.Get(“defaultNamingContext”)

 

 

Set oDomain = GetObject(“LDAP://” & sDomain)

 

sBase = “<” & oDomain.ADsPath & “>”

‘Only get user name requested

sFilter = “(objectClass=*)”

sAttribs = “AdsPath, cn”

sDepth = “subTree”

 

sQuery = sBase & “;” & sFilter & “;” & sAttribs & “;” & sDepth

‘Add the domain to the user name

If InStr(1, txtUser.Text, “domainname”) = 0 Then

usern = “domainname” & txtUser.Text

Else

usern = txtUser.Text

End If

 

Set conn = CreateObject(“ADODB.Connection”)

conn.Provider = “ADsDSOObject”

conn.Properties(“User Id”) = usern

conn.Properties(“Password”) = txtPass.Text

conn.Properties(“Encrypt Password”) = True

‘Set Flags to ensure secure authentication is used instead of simple

conn.Properties(“ADSI Flag”) = ADS_SECURE_AUTHENTICTION + ADS_USE_SSL

 

conn.Open “Active Directory Provider”

 

Set rs = conn.Execute(sQuery)

GoTo ExitSub

 

ErrHandler:

 

On Error Resume Next

If Not rs Is Nothing Then

If rs.State <> 0 Then rs.Close

Set rs = Nothing

 

End If

 

If Not conn Is Nothing Then

If conn.State <> 0 Then conn.Close

Set conn = Nothing

 

End If

 

Set oRoot = Nothing

Set oDomain = Nothing

MsgBox “You are not authorized to use this application, please contact an Administrator.”

Application.Quit

 

ExitSub:

Unload Me

 

End Sub