Imports System.DirectoryServices Imports System.DirectoryServices.ActiveDirectory Imports System.DirectoryServices.AccountManagement Public Class frmUserKonfig_AddUsers Private Sub formUserConfig_AddUsers_Load(sender As Object, e As EventArgs) Handles MyBase.Load Try Cursor = Cursors.WaitCursor GetGroups(Environment.UserName) Catch ex As Exception MsgBox("Error in Load Groups:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) End Try Cursor = Cursors.Default End Sub Function GetActiveDirectoryGroups() As List(Of String) 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 Return groups Catch ex As Exception MsgBox("Error in GetActiveDirectoryGroups:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) Return Nothing End Try 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 Dim group As String = lbGroups.SelectedItem Dim users As List(Of UserPrincipal) = GetUsersForGroup(group) clbUsers.Items.Clear() For Each user In users clbUsers.Items.Add(user) Next End Sub Private Sub btnAddUsers_Click(sender As Object, e As EventArgs) Handles btnAddUsers.Click Dim items As CheckedListBox.CheckedItemCollection = clbUsers.CheckedItems Dim usersAdded As Integer = 0 If items.Count = 0 Then MsgBox("Keine Benutzer ausgewählt!", MsgBoxStyle.Information) Exit Sub End If For Each item As UserPrincipal In items Dim user As UserPrincipal = item Dim PRENAME As String = user.GivenName Dim NAME As String = user.Surname Dim USERNAME As String = user.SamAccountName Dim email As String = user.EmailAddress Dim SQL If Not UserExists(USERNAME) Then SQL = "INSERT INTO TBDD_USER(PRENAME, NAME, USERNAME, EMAIL, MODULE_RECORD_ORG,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_RECORD_ORG = 1 WHERE UPPER(USERNAME) = UPPER('" & USERNAME & "')" If ClassDatabase.Execute_non_Query(SQL) = True Then usersAdded = usersAdded + 1 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 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) = 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 Dim userstring As String = clbUsers.SelectedItem.ToString Dim userldap As UserPrincipal = clbUsers.SelectedItem Dim PRENAME As String = userldap.GivenName Dim NAME As String = userldap.Surname Dim USERNAME As String = userldap.SamAccountName Dim email As String = userldap.EmailAddress ToolTipController1.HideHint() ToolTipController1.ShowHint("Used ldap paramters:", userstring & USERNAME & vbNewLine & email, DevExpress.Utils.ToolTipLocation.RightCenter) End Sub Private Sub RBCheck2_CheckedChanged(sender As Object, e As EventArgs) Handles RBCheck2.CheckedChanged If RBCheck2.Checked Then GetGroups(Environment.UserName) End If End Sub Public Sub GetGroups(ByVal samAccountName As String) Try Cursor = Cursors.WaitCursor lbGroups.Items.Clear() Dim domainConnection = New DirectoryEntry() domainConnection.AuthenticationType = System.DirectoryServices.AuthenticationTypes.Secure Dim samSearcher = New DirectorySearcher() samSearcher.SearchRoot = domainConnection samSearcher.Filter = "(samAccountName=" & samAccountName & ")" samSearcher.PropertiesToLoad.Add("displayName") Dim samResult = samSearcher.FindOne() If samResult IsNot Nothing Then Dim theUser = samResult.GetDirectoryEntry() theUser.RefreshCache(New String() {"tokenGroups"}) For Each resultBytes As Byte() In theUser.Properties("tokenGroups") Dim SID = New System.Security.Principal.SecurityIdentifier(resultBytes, 0) Dim sidSearcher = New DirectorySearcher() sidSearcher.SearchRoot = domainConnection sidSearcher.Filter = "(objectSid=" & SID.Value & ")" sidSearcher.PropertiesToLoad.Add("name") Dim sidResult = sidSearcher.FindOne() If sidResult IsNot Nothing Then Dim groupname = CStr(sidResult.Properties("name")(0)) If Not groupname.StartsWith("WinRMR") And Not groupname.StartsWith("Gäst") And Not groupname.StartsWith("Druck") And Not groupname.StartsWith("Sicherungs") And Not groupname.StartsWith("Replikations") And Not groupname.StartsWith("Netzwerkskon") _ And Not groupname.StartsWith("Leistungs") And Not groupname.StartsWith("Distributed COM") And Not groupname.StartsWith("IIS_") And Not groupname.StartsWith("Kryptografie") And Not groupname.StartsWith("Ereignis") And Not groupname.StartsWith("Zertifikat") _ And Not groupname.StartsWith("RDS-") And Not groupname.StartsWith("Hyper-V") And Not groupname.StartsWith("Zugriffssteuerungs") And Not groupname.StartsWith("Remoteverwaltungs") And Not groupname.StartsWith("Domänencomput") And Not groupname.StartsWith("Domänen-Gäste") _ And Not groupname.StartsWith("Richtlinien-Ersteller") And Not groupname.StartsWith("SQLAccess") And Not groupname.StartsWith("RAS- und IAS-Server") And Not groupname.StartsWith("Server-Operatore") And Not groupname.StartsWith("Konten-Oper") And Not groupname.StartsWith("Prä-Windows") _ And Not groupname.StartsWith("Einstellungen eingehender") And Not groupname.StartsWith("Windows-Auth") And Not groupname.StartsWith("Terminalserver-Liz") And Not groupname.StartsWith("Zulässige") And Not groupname.StartsWith("Abgelehnte") And Not groupname.StartsWith("Schreibgeschützte Domänen") _ And Not groupname.StartsWith("Klonbare") And Not groupname.StartsWith("PrivUser") And Not groupname.StartsWith("Protected User") And Not groupname.StartsWith("Dns") And Not groupname.StartsWith("DHCP") And Not groupname.StartsWith("IIS_IUSR") And Not groupname.StartsWith("Richtlinien-Ersteller") _ And Not groupname.StartsWith("Abgelehnte RODC-Kenn") And Not groupname.StartsWith("Reporting") Then ' Console.WriteLine(CStr(sidResult.Properties("name")(0))) lbGroups.Items.Add(groupname) End If End If Next resultBytes End If Catch ex As Exception MsgBox("Error in GetGroups:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) End Try Cursor = Cursors.Default End Sub Private Sub RBCheck1_CheckedChanged(sender As Object, e As EventArgs) Handles RBCheck1.CheckedChanged If RBCheck1.Checked Then Try Cursor = Cursors.WaitCursor Dim groups = GetActiveDirectoryGroups() lbGroups.Items.Clear() If Not IsNothing(groups) Then For Each group In groups lbGroups.Items.Add(group) Next End If Catch ex As Exception MsgBox("Error in Load Groups:" & vbNewLine & ex.Message, MsgBoxStyle.Critical) End Try Cursor = Cursors.Default End If End Sub End Class