Imports System.DirectoryServices Imports System.DirectoryServices.ActiveDirectory Imports System.DirectoryServices.AccountManagement Public Class frmUserKonfig_AddUsers Public Function GetAllADGroups() As List(Of String) Try Dim enTry As DirectoryEntry = New DirectoryEntry("LDAP://" & Environment.UserDomainName) 'digitaldata.local Dim mySearcher As DirectorySearcher = New DirectorySearcher(enTry) mySearcher.Filter = ("(&(objectClass=group))") Dim result As New List(Of String) For Each resEnt As SearchResult In mySearcher.FindAll() Dim myEntry As DirectoryEntry = resEnt.GetDirectoryEntry Dim groupName As String = myEntry.Name.Replace("CN=", "") If Not groupName.StartsWith("WinRMR") Or Not groupName.StartsWith("Gäst") Or Not groupName.StartsWith("Druck") Or Not groupName.StartsWith("Sicherungs") Or Not groupName.StartsWith("Replikations") Or Not groupName.StartsWith("Netzwerkskon") _ Or Not groupName.StartsWith("Leistungs") Or Not groupName.StartsWith("Distributed COM") Or Not groupName.StartsWith("IIS_") Or Not groupName.StartsWith("Kryptografie") Or Not groupName.StartsWith("Ereignis") Or Not groupName.StartsWith("Zertifikat") _ Or Not groupName.StartsWith("RDS-") Or Not groupName.StartsWith("Hyper-V") Or Not groupName.StartsWith("Zugriffssteuerungs") Or Not groupName.StartsWith("Remoteverwaltungs") Or Not groupName.StartsWith("Domänencomput") Or Not groupName.StartsWith("Domänen-Gäste") _ Or Not groupName.StartsWith("Richtlinien-Ersteller") Or Not groupName.StartsWith("RAS- und IAS-Server") Or Not groupName.StartsWith("Server-Operatore") Or Not groupName.StartsWith("Konten-Oper") Or Not groupName.StartsWith("Prä-Windows") _ Or Not groupName.StartsWith("Einstellungen eingehender") Or Not groupName.StartsWith("Windows-Auth") Or Not groupName.StartsWith("Terminalserver-Liz") Or Not groupName.StartsWith("Zulässige") Or Not groupName.StartsWith("Abgelehnte") Or Not groupName.StartsWith("Schreibgeschützte Domänen") _ Or Not groupName.StartsWith("Klonbare") Or Not groupName.StartsWith("Protected User") Or Not groupName.StartsWith("Dns") Or Not groupName.StartsWith("DHCP") Or Not groupName.StartsWith("IIS_IUSR") Or Not groupName.StartsWith("Richtlinien-Ersteller") _ Or Not groupName.StartsWith("Abgelehnte RODC-Kenn") Then Dim users As List(Of String) = GetGroupUsers(groupName) If Not IsNothing(users) Then result.Add(groupName) End If End If 'MsgBox(myEntry.Name) 'Dim MyLVI As ListViewItem = ListView2.Items.Add(Rc(myEntry.Name)) 'MyLVI.SubItems.Add("Global Secutiry Group") 'MyLVI.SubItems.Add(Replace(myEntry.Parent.Path, "LDAP://", "")) 'MyLVI.ImageKey = "ad_icon_group" Next 'Dim sPath As String = "LDAP://digitaldata.local" 'Dim myDirectory As New DirectoryEntry(sPath) 'Dim mySearcher1 As New DirectorySearcher(myDirectory) 'Dim mySearchResultColl As SearchResultCollection 'Dim mySearchResult As SearchResult 'Dim result As New List(Of String) 'Dim objGroupEntry As DirectoryEntry 'mySearcher1.Filter = "(&(objectClass=Group))" 'mySearchResultColl = mySearcher1.FindAll() 'If (mySearchResultColl.Count <> 0) Then ' For Each mySearchResult In mySearchResultColl ' objGroupEntry = mySearchResult.GetDirectoryEntry() ' result.Add(objGroupEntry.Name) ' Next 'End If Return result Catch ex As System.Exception Return Nothing End Try End Function Private Sub formUserConfig_AddUsers_Load(sender As Object, e As EventArgs) Handles MyBase.Load Try Me.Cursor = Cursors.WaitCursor Dim groups As List(Of String) = GetAllADGroups() ' Sort alphabetically. groups.Sort() Me.Cursor = Cursors.Default For Each group In groups lbGroups.Items.Add(group) Next 'Dim groups As List(Of String) = GetActiveDirectoryGroups() 'For Each group In groups ' lbGroups.Items.Add(group) 'Next Catch ex As Exception MsgBox("Error in Load Groups: " & vbNewLine & ex.Message, MsgBoxStyle.Critical) End Try Me.Cursor = Cursors.Default End Sub Public Function GetUsername_FromDisplayname(ByVal strUserString As String) Try Dim enTry As DirectoryEntry = New DirectoryEntry("LDAP://" & Environment.UserDomainName) 'digitaldata.local Dim mySearcher As DirectorySearcher = New DirectorySearcher(enTry) mySearcher.Filter = ("(&(objectCategory=person)(objectClass=user)(cn=" & strUserString & "))") 'Retrieve results Dim dsResult As SearchResult = mySearcher.FindOne If dsResult Is Nothing Then 'No results returned Return "" End If 'For Each Str As DictionaryEntry In dsResult.Properties ' Console.WriteLine(Str.Key.ToString & " - " & Str.Value.ToString) 'Next Dim usrname = dsResult.Properties("samaccountname")(0) Return usrname Catch ex As Exception ClassLogger.Add("Error in GetUsername_FromDisplayname: " & ex.Message, True) Return "" End Try End Function Public Function GetProperty_LDAP(ByVal strUserString As String, _property As String) Try Dim enTry As DirectoryEntry = New DirectoryEntry("LDAP://" & Environment.UserDomainName) 'digitaldata.local Dim mySearcher As DirectorySearcher = New DirectorySearcher(enTry) mySearcher.Filter = ("(&(objectCategory=person)(objectClass=user)(cn=" & strUserString & "))") 'Retrieve results Dim dsResult As SearchResult = mySearcher.FindOne If dsResult Is Nothing Then 'No results returned Return "" End If 'For Each Str As DictionaryEntry In dsResult.Properties ' Console.WriteLine(Str.Key.ToString & " - " & Str.Value.ToString) 'Next Dim usrname = dsResult.Properties(_property)(0) Return usrname Catch ex As Exception ClassLogger.Add("Error in GetProperty_LDAP: " & ex.Message, True) Return "" End Try End Function Public Function GetEmail_FromDisplayname(ByVal strUserString As String) Try Dim enTry As DirectoryEntry = New DirectoryEntry("LDAP://" & Environment.UserDomainName) 'digitaldata.local Dim mySearcher As DirectorySearcher = New DirectorySearcher(enTry) mySearcher.Filter = ("(&(objectCategory=person)(objectClass=user)(cn=" & strUserString & "))") 'Retrieve results Dim dsResult As SearchResult = mySearcher.FindOne If dsResult Is Nothing Then 'No results returned Return "" End If 'For Each Str As DictionaryEntry In dsResult.Properties ' Console.WriteLine(Str.Key.ToString & " - " & Str.Value.ToString) 'Next Dim email = dsResult.Properties("mail")(0) Return email Catch ex As Exception ClassLogger.Add("Error in GetEmail_FromDisplayname: " & ex.Message, True) Return "" End Try End Function Public Shared Function FindEmailsFromSamAccountName(ByVal samAccountName As String) As String Dim ctx As New PrincipalContext(ContextType.Domain) Dim qbeUser As New UserPrincipal(ctx) qbeUser.SamAccountName = samAccountName qbeUser.Enabled = True Dim srch As New PrincipalSearcher(qbeUser) For Each foundUser In srch.FindAll Dim up As UserPrincipal = CType(foundUser, UserPrincipal) Return up.EmailAddress Next Return "" End Function Function GetActiveDirectoryGroups() As List(Of String) Me.Cursor = Cursors.WaitCursor Dim groups As List(Of String) = New List(Of String) Dim ctx As PrincipalContext = New PrincipalContext(ContextType.Domain) Dim group As GroupPrincipal = New GroupPrincipal(ctx) Dim srch As PrincipalSearcher = New PrincipalSearcher(group) For Each g In srch.FindAll() If GetUsersForGroup(g.ToString()).Count <> 0 Then groups.Add(g.ToString) End If Next Return groups End Function Public Function GetGroupUsers(ByVal strGroupName As String) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ' Returns all the users of a specific group ' Each user on seperate line in the string ' The group name being passed is not case sensitive ' '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Dim dsDirectorySearcher As New DirectorySearcher Dim strUsers As String Dim intEqualsIndex As Integer Dim intCommaIndex As Integer Dim result As New List(Of String) 'Filter by group name With dsDirectorySearcher .Filter = "sAMAccountName=" & strGroupName .PropertiesToLoad.Add("member") Try 'Retrieve results Dim dsResult As SearchResult = .FindOne Dim intCounter As Integer If dsResult Is Nothing Then 'No results returned Return Nothing End If Dim d = dsResult.Properties("member").Count For intCounter = 0 To dsResult.Properties("member").Count - 1 strUsers = dsResult.Properties("member")(intCounter).ToString If LogErrorsOnly = False Then ClassLogger.Add(">> Usermember-String for Group: " & strUsers.ToString, False) 'Get index of equals and comma intEqualsIndex = strUsers.IndexOf("=", 1) intCommaIndex = strUsers.IndexOf(",", 1) If intEqualsIndex = -1 Then Return Nothing End If 'Console.WriteLine(strUsers) 'Extract name from string and append to List result.Add(strUsers.Substring((intEqualsIndex + 1), (intCommaIndex - intEqualsIndex) - 1)) Next intCounter Catch ex As Exception MessageBox.Show("Error in GetGroupUsers Function" & vbNewLine & vbNewLine _ & ex.Message, "Active Directory Error", MessageBoxButtons.OK, MessageBoxIcon.Error) End Try End With Return result End Function Function GetUsersForGroup(g As String) As List(Of UserPrincipal) Dim users As List(Of UserPrincipal) = New List(Of UserPrincipal) 'Dim ctx As PrincipalContext = New PrincipalContext(ContextType.Domain) 'Dim group As GroupPrincipal = GroupPrincipal.FindByIdentity(ctx, g) 'Dim u = group.GetMembers(True) 'For Each user In u ' If user.GetType().Name = "UserPrincipal" Then ' users.Add(user) ' End If 'Next Return users End Function Private Sub lbGroups_SelectedIndexChanged(sender As Object, e As EventArgs) Handles lbGroups.SelectedIndexChanged Me.Cursor = Cursors.WaitCursor Dim group As String = lbGroups.SelectedItem Dim users As List(Of String) = GetGroupUsers(group) clbUsers.Items.Clear() If users Is Nothing Then Me.Cursor = Cursors.Default Exit Sub End If For Each user In users If user.EndsWith("/") Or user.EndsWith("\") Then user = user.Replace("/", "") user = user.Replace("\", "") End If clbUsers.Items.Add(user) Next Me.Cursor = Cursors.Default End Sub Private Sub btnAddUsers_Click(sender As Object, e As EventArgs) Handles btnAddUsers.Click Try Dim items As CheckedListBox.CheckedItemCollection = clbUsers.CheckedItems Dim usersAdded As Integer = 0 If items.Count = 0 Then MsgBox("Keine Benutzer ausgewählt") Exit Sub End If For Each item In items Dim ctx As PrincipalContext = New PrincipalContext(ContextType.Domain) Dim usr As UserPrincipal = UserPrincipal.FindByIdentity(ctx, IdentityType.Name, item.ToString) If Not IsNothing(usr) Then 'Dim user As String = item.ToString 'Dim PRENAME As String = GetProperty_LDAP(user, "givenName") 'Dim NAME As String = GetProperty_LDAP(user, "sn") 'Dim email As String = GetProperty_LDAP(user, "mail") 'Dim USERNAME As String = GetProperty_LDAP(user, "samaccountname") Dim PRENAME As String = usr.GivenName Dim NAME As String = usr.Surname Dim USERNAME As String = usr.SamAccountName Dim email As String = usr.EmailAddress Dim SQL If Not UserExists(USERNAME) Then SQL = String.Format("INSERT INTO TBDD_USER(PRENAME, NAME, USERNAME, EMAIL, MODULE_GI,ADDED_WHO) VALUES('{0}', '{1}', '{2}','{3}',1,'{4}')", PRENAME, NAME, USERNAME, email, Environment.UserName) If ClassDatabase.Execute_non_Query(SQL) = True Then usersAdded = usersAdded + 1 End If Else SQL = "UPDATE TBDD_USER SET MODULE_GI = 1 WHERE UPPER(USERNAME) = UPPER('" & USERNAME & "')" If ClassDatabase.Execute_non_Query(SQL) = True Then usersAdded = usersAdded + 1 End If End If Else MsgBox("Für den User '" & item.ToString & "' konnte kein Userprincipal aus der LDAP erstellt werden!", MsgBoxStyle.Information) End If Next If usersAdded = 1 Then MsgBox(usersAdded & " neuer Benutzer hinzugefügt", MsgBoxStyle.Information) Else MsgBox(usersAdded & " neue Benutzer hinzugefügt", MsgBoxStyle.Information) End If Catch ex As Exception MsgBox("Error in Adding Users from LDAP: " & vbNewLine & ex.Message) End Try End Sub Private Function UserExists(username As String) As Boolean Try Dim SQL = "SELECT GUID FROM TBDD_USER WHERE UPPER(USERNAME) = UPPER('" & username & "')" If ClassDatabase.Execute_Scalar(SQL, MyConnectionString) = Nothing Then Return False Else Return True End If Catch ex As Exception MsgBox("Error in UserExists: " & vbNewLine & ex.Message) Return False End Try End Function Private Sub btnCancel_Click(sender As Object, e As EventArgs) Handles btnCancel.Click Me.Close() End Sub Private Sub tbSelectEverything_Click(sender As Object, e As EventArgs) Handles tbSelectEverything.Click For i = 0 To clbUsers.Items.Count - 1 clbUsers.SetItemChecked(i, True) Next End Sub Private Sub tbSelectNone_Click(sender As Object, e As EventArgs) Handles tbSelectNone.Click For i = 0 To clbUsers.Items.Count - 1 clbUsers.SetItemChecked(i, False) Next End Sub 'Private Sub clbUsers_SelectedIndexChanged(sender As Object, e As EventArgs) Handles clbUsers.SelectedIndexChanged ' Me.Cursor = Cursors.WaitCursor ' Dim user As String = clbUsers.SelectedItem ' Dim usrname = GetProperty_LDAP(user, "samaccountname") ' If Not IsNothing(usrname) Then ' MsgBox(usrname) ' End If ' Dim email = GetProperty_LDAP(user, "mail") ' If Not IsNothing(email) Then ' MsgBox(email) ' End If 'End Sub Private Sub clbUsers_MouseClick(sender As Object, e As MouseEventArgs) Handles clbUsers.MouseClick Try ToolTipController1.HideHint() Dim userstring As String = clbUsers.SelectedItem.ToString Dim ctx As PrincipalContext = New PrincipalContext(ContextType.Domain) Dim usr As UserPrincipal = UserPrincipal.FindByIdentity(ctx, IdentityType.Name, userstring) If Not IsNothing(usr) Then Dim PRENAME As String = usr.GivenName Dim NAME As String = usr.Surname Dim USERNAME As String = usr.SamAccountName Dim email As String = usr.EmailAddress ToolTipController1.ShowHint("SamAccountName: " & USERNAME & vbNewLine & "GivenName: " & PRENAME & vbNewLine & "Surname: " & NAME & vbNewLine & "EmailAddress: " & email, "Preview LDAP-Parameter:", DevExpress.Utils.ToolTipLocation.RightCenter) End If ctx.Dispose() Catch ex As Exception MsgBox("Error in getting Userinfo LDAP:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) End Try End Sub End Class