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
