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 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 Try 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 If Not g.ToString.StartsWith("WinRMR") And Not g.ToString.StartsWith("Priv") And Not g.ToString.StartsWith("Gäst") And Not g.ToString.StartsWith("Druck") And Not g.ToString.StartsWith("Sicherungs") And Not g.ToString.StartsWith("Replikations") And Not g.ToString.StartsWith("Netzwerkskon") _ And Not g.ToString.StartsWith("Reporting") And Not g.ToString.StartsWith("Leistungs") And Not g.ToString.StartsWith("Distributed COM") And Not g.ToString.StartsWith("IIS_") And Not g.ToString.StartsWith("Kryptografie") And Not g.ToString.StartsWith("Ereignis") And Not g.ToString.StartsWith("Zertifikat") _ And Not g.ToString.StartsWith("RDS-") And Not g.ToString.StartsWith("Hyper-V") And Not g.ToString.StartsWith("Zugriffssteuerungs") And Not g.ToString.StartsWith("Remoteverwaltungs") And Not g.ToString.StartsWith("Domänencomput") And Not g.ToString.StartsWith("Domänen-Gäste") _ And Not g.ToString.StartsWith("Richtlinien-Ersteller") And Not g.ToString.StartsWith("RAS- und IAS-Server") And Not g.ToString.StartsWith("Server-Operatore") And Not g.ToString.StartsWith("Konten-Oper") And Not g.ToString.StartsWith("Prä-Windows") _ And Not g.ToString.StartsWith("SQLAcce") And Not g.ToString.StartsWith("Einstellungen eingehender") And Not g.ToString.StartsWith("Windows-Auth") And Not g.ToString.StartsWith("Terminalserver-Liz") And Not g.ToString.StartsWith("Zulässige") And Not g.ToString.StartsWith("Abgelehnte") And Not g.ToString.StartsWith("Schreibgeschützte Domänen") _ And Not g.ToString.StartsWith("Klonbare") And Not g.ToString.StartsWith("Protected User") And Not g.ToString.StartsWith("Dns") And Not g.ToString.StartsWith("DHCP") And Not g.ToString.StartsWith("IIS_IUSR") And Not g.ToString.StartsWith("Richtlinien-Ersteller") _ And Not g.ToString.StartsWith("Abgelehnte RODC-Kenn") Then groups.Add(g.ToString) End If End If Next Me.Cursor = Cursors.Default Return groups Catch ex As Exception MsgBox("Error in GetActiveDirectoryGroups:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) Me.Cursor = Cursors.Default Return Nothing End Try 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 UserPrincipal) = GetUsersForGroup(group) MyDataset.TBAD_Users.Clear() For Each user In users Dim newUserRow As MyDataset.TBAD_UsersRow newUserRow = MyDataset.TBAD_Users.NewTBAD_UsersRow Try Dim userldap As UserPrincipal = user Dim PRENAME As String = userldap.GivenName Dim NAME As String = userldap.Surname Dim USERNAME As String = userldap.SamAccountName Dim _name = userldap.DisplayName Dim _name1 = userldap.Name Dim _name3 = userldap.Name Try newUserRow.Username = userldap.SamAccountName Catch ex As Exception newUserRow.Username = user.ToString End Try Dim email As String Try email = userldap.EmailAddress Catch ex As Exception email = "" End Try newUserRow.Prename = PRENAME newUserRow.Surname = NAME newUserRow.Email = email Catch ex As Exception ClassLogger.Add("Unexpected Error in Read User LDAP-Configurations: " & vbNewLine) End Try MyDataset.TBAD_Users.Rows.Add(newUserRow) Next Me.Cursor = Cursors.Default End Sub Private Sub btnAddUsers_Click(sender As Object, e As EventArgs) Handles btnAddUsers.Click Try Dim usersAdded As Integer = 0 For Each row As DataRow In MyDataset.TBAD_Users.Rows If CBool(row.Item(0)) = CBool(True) Then Dim USERNAME As String = row.Item(1) Dim PRENAME As String = row.Item(2) Dim NAME As String = row.Item(3) Dim email As String Try email = row.Item(4) Catch ex As Exception email = "" End Try Dim SQL If Not UserExists(USERNAME) Then SQL = "INSERT INTO TBDD_USER(PRENAME, NAME, USERNAME, EMAIL, MODULE_GI,LANGUAGE) VALUES('" & PRENAME & "', '" & NAME & "', '" & USERNAME & "','" & email & "'," & 1 & ",'" & USER_LANGUAGE & "')" 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 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 Each Row As DataRow In MyDataset.TBAD_Users.Rows Row.Item(0) = True Next End Sub Private Sub tbSelectNone_Click(sender As Object, e As EventArgs) Handles tbSelectNone.Click For Each Row As DataRow In MyDataset.TBAD_Users.Rows Row.Item(0) = False Next End Sub 'Private Sub clbUsers_MouseClick(sender As Object, e As MouseEventArgs) ' 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