[VB.NET] QoS Limiter

[HackTec]

Download




Source

 Spoiler

Imports System.Management
Imports System.Security.Principal
Imports System.Windows.Forms.VisualStyles.VisualStyleEleme nt
Imports Microsoft.Win32
Public Class QoSHandle

Public Class QoSRuleDataPack
Public Name As String
Public Bandwidth As Integer
Public BandwidthParameter As String
End Class

Dim allProcesses As IEnumerable(Of Process) = Process.GetProcesses()
Dim searcher As ManagementObjectSearcher = Nothing
Public QoSSaveName As String = "QoSDat.json"

Private Function IsRunningAsAdmin() As Boolean
Dim identity = WindowsIdentity.GetCurrent()
Dim principal = New WindowsPrincipal(identity)
Return principal.IsInRole(WindowsBuiltInRole.Administrato r)
End Function

Private Sub RestartAsAdmin()
Dim currentProcess As Process = Process.GetCurrentProcess()
Dim startInfo As New ProcessStartInfo()
startInfo.UseShellExecute = True
startInfo.WorkingDirectory = Environment.CurrentDirectory
startInfo.FileName = currentProcess.MainModule.FileName
startInfo.Verb = "runas"
Try
Process.Start(startInfo)
Catch ex As Exception
Console.WriteLine("Fehler beim Ausführen des Programms als Administrator: " & ex.Message)
End Try
End Sub

Private Async Sub QoSHandle_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load

If IsRunningAsAdmin() Then
Await ReloadingStartAsync()
Await WSHLoading()
LoadQoSRegistryKeys()
Else
MsgBox("Restart as Admin better")
Await ReloadingStartAsync()
Await WSHLoading()

LoadQoSRegistryKeys()
End If

QoSActivate()

QoSData.Columns.Add("Name", 80)
QoSData.Columns.Add("Bytes transmitted", 100)
QoSData.Columns.Add("Packets transmitted", 100)
QoSData.Columns.Add("Packets dropped", 100)

End Sub

Public Async Function ReloadingStartAsync() As Task
For Each proc As Process In Process.GetProcesses()
Processlistbox.Items.Add(proc.ProcessName)
Next
End Function

Private Sub Processlistbox_SelectedIndexChanged(sender As System.Object, e As System.EventArgs) Handles Processlistbox.SelectedIndexChanged
If Processlistbox.SelectedItem IsNot Nothing Then
QoSNewName.Text = Processlistbox.SelectedItem.ToString()
QoSNewBandwidthParameter.Text = "KB"
QoSNewBandwidth.Value = If(Integer.TryParse(QoSNewBandwidth.Text, CInt(QoSNewBandwidth.Value)), QoSNewBandwidth.Value, 0)
End If
End Sub

Private Sub RefreshProcessList_Click(sender As System.Object, e As System.EventArgs) Handles RefreshProcessList.Click
Processlistbox.Items.Clear()
For Each proc As Process In Process.GetProcesses()
Processlistbox.Items.Add(proc.ProcessName)
Next
End Sub

Private Sub QoSSearch_TextChanged(sender As Object, e As EventArgs) Handles QoSSearch.TextChanged
Dim searchQuery As String = QoSSearch.Text.ToLower()
Processlistbox.Items.Clear()
For Each proc As Process In Process.GetProcesses()
If proc.ProcessName.ToLower().Contains(searchQuery) Then
Processlistbox.Items.Add(proc.ProcessName)
End If
Next
End Sub

Private Sub QoSCreateForList_Click(sender As System.Object, e As System.EventArgs) Handles QoSCreateForList.Click
If Not String.IsNullOrEmpty(QoSNewName.Text) AndAlso QoSNewBandwidth.Value <> 0 AndAlso Not String.IsNullOrEmpty(QoSNewBandwidthParameter.Text ) Then
If MessageBox.Show("Add New QoS Rule, are you sure anything is right?" + vbNewLine + vbNewLine + "Name: " + QoSNewName.Text + vbNewLine + "Bandwidth: " + QoSNewBandwidth.Value.ToString + " " + QoSNewBandwidthParameter.Text, "Info", MessageBoxButtons.YesNo) = DialogResult.Yes Then
Dim qosRule As New QoSRuleDataPack With {.Name = QoSNewName.Text, .Bandwidth = CInt(QoSNewBandwidth.Value), .BandwidthParameter = QoSNewBandwidthParameter.Text}
SetQoSRule(qosRule)
End If
Else
MsgBox("Error")
End If
LoadQoSRegistryKeys()
End Sub

Private Async Sub QoSrulesList_SelectedIndexChanged(sender As System.Object, e As System.EventArgs) Handles QoSrulesList.SelectedIndexChanged
QoSData.Items.Clear()
Await WSHLoading()

If QoSrulesList.SelectedIndex >= 0 Then
Try
Dim selectedRuleName As String = QoSrulesList.Items(QoSrulesList.SelectedIndex).ToS tring()
Dim keyPath As String = "SOFTWARE\Policies\Microsoft\Windows\QoS" & selectedRuleName
Dim key As RegistryKey = Registry.LocalMachine.OpenSubKey(keyPath)

QoSNewName.Text = selectedRuleName
Dim newValue As Integer = Integer.Parse(key.GetValue("Throttle Rate", 0).ToString())
newValue = newValue \ 8
QoSNewBandwidth.Value = newValue
'QoSNewBandwidth.Value = Integer.Parse(key.GetValue("Throttle Rate", 0).ToString())
QoSNewBandwidthParameter.Text = "KB"
key.Close()
Catch ex As Exception

End Try
End If

End Sub

Private Sub LoadQoSRegistryKeys()
QoSrulesList.Items.Clear()

Try
Dim keyPath As String = "SOFTWARE\Policies\Microsoft\Windows\QoS"
Dim key As RegistryKey = Registry.LocalMachine.OpenSubKey(keyPath)

If key IsNot Nothing Then
For Each subKeyName As String In key.GetSubKeyNames()
QoSrulesList.Items.Add(subKeyName)
Next
key.Close()
End If
Catch ex As Exception
MessageBox.Show("Error loading QoS registry keys: " & ex.Message)
End Try
End Sub


Public Sub SetQoSRule(ByVal qosRule As QoSRuleDataPack)
If String.IsNullOrEmpty(qosRule.Name) Then Throw New ArgumentException("Der Regelname darf nicht leer sein.", NameOf(qosRule.Name))

Try
Dim keyPath As String = "SOFTWARE\Policies\Microsoft\Windows\QoS" + qosRule.Name
Dim key As RegistryKey = Registry.LocalMachine.CreateSubKey(keyPath, True)

key.SetValue("Version", "1.0")
key.SetValue("Application Name", qosRule.Name & ".exe")
key.SetValue("Protocol", "*")
key.SetValue("Local Port", "*")
key.SetValue("Local IP", "*")
key.SetValue("Local IP Prefix Length", "*")
key.SetValue("Remote Port", "*")
key.SetValue("Remote IP", "*")
key.SetValue("Remote IP Prefix Length", "*")
key.SetValue("DSCP Value", "46")


Dim throttleRate As Integer = qosRule.Bandwidth
Select Case qosRule.BandwidthParameter
Case "MB"
throttleRate *= 1024 * 8
Case "KB"
throttleRate *= 8
Case Else

End Select

key.SetValue("Throttle Rate", throttleRate.ToString())

key.Close()
Catch ex As Exception
MessageBox.Show("Error: " & ex.Message)
End Try
End Sub

Sub QoSActivate()
Try
Dim tcpipKeyPath As String = "SYSTEM\CurrentControlSet\services\Tcpip\Parameter s"
Dim tcpipKey As RegistryKey = Registry.LocalMachine.OpenSubKey(tcpipKeyPath, True)
If tcpipKey Is Nothing Then tcpipKey = Registry.LocalMachine.CreateSubKey(tcpipKeyPath)
If tcpipKey.GetValue("DisableUserTOSSetting") Is Nothing Then tcpipKey.SetValue("DisableUserTOSSetting", 0, RegistryValueKind.DWord)
tcpipKey.Close()

Dim qosKeyPath As String = "SYSTEM\CurrentControlSet\services\Tcpip\QoS"
Dim qosKey As RegistryKey = Registry.LocalMachine.OpenSubKey(qosKeyPath, True)
If qosKey Is Nothing Then qosKey = Registry.LocalMachine.CreateSubKey(qosKeyPath)
If qosKey.GetValue("Do not use NLA") Is Nothing Or 0 Then qosKey.SetValue("Do not use NLA", 1, RegistryValueKind.String)
qosKey.Close()

Catch ex As Exception
MsgBox("Error: " & ex.Message)
End Try
End Sub

Sub QoSDeactivate()
Try
Dim parentKey As RegistryKey = Registry.LocalMachine.OpenSubKey("SYSTEM\CurrentCo ntrolSet\services\Tcpip\Parameters", True)
parentKey?.DeleteValue("DisableUserTOSSetting", False)
parentKey?.Close()
Registry.LocalMachine.DeleteSubKeyTree("SYSTEM\Cur rentControlSet\services\Tcpip\QoS")
Catch ex As Exception
MsgBox("Error: " & ex.Message)
End Try
End Sub

Private Sub QoSDeleteFromList_Click(sender As Object, e As EventArgs) Handles QoSDeleteFromList.Click
If QoSrulesList.SelectedIndex <> -1 Then
DeleteQoSRule(QoSrulesList.SelectedIndex)
Else
MessageBox.Show("Please select an item to delete.", "Information", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End Sub

Public Sub DeleteQoSRule(ByVal ruleName As String)
If String.IsNullOrEmpty(ruleName) Then Throw New ArgumentException("Der Regelname darf nicht leer sein.", NameOf(ruleName))

Try
Dim keyPath As String = "SOFTWARE\Policies\Microsoft\Windows\QoS" + ruleName
If Registry.LocalMachine.OpenSubKey(keyPath) IsNot Nothing Then Registry.LocalMachine.DeleteSubKeyTree(keyPath)
Catch ex As Exception
MsgBox("Error:" + ex.Message)
End Try
End Sub

Private Sub QoSNewBandwidthParameter_SelectedIndexChanged(send er As Object, e As EventArgs) Handles QoSNewBandwidthParameter.SelectedIndexChanged
Dim newValue As Integer
newValue = 0
If QoSNewBandwidthParameter.SelectedItem IsNot Nothing AndAlso QoSNewBandwidthParameter.SelectedItem.ToString() = "MB" Then
newValue = QoSNewBandwidth.Value \ 1024
QoSNewBandwidth.Value = newValue
ElseIf QoSNewBandwidthParameter.SelectedItem IsNot Nothing AndAlso QoSNewBandwidthParameter.SelectedItem.ToString() = "KB" Then
newValue = QoSNewBandwidth.Value * 1024
QoSNewBandwidth.Value = newValue
End If
End Sub


Private Async Function WSHLoading() As Task
QoSData.Items.Clear()



Dim strComputer As String = "."
Dim objWMIService As ManagementObjectSearcher = New ManagementObjectSearcher("root\CIMV2", "SELECT * FROM Win32_PerfRawData_Counters_NetworkQoSPolicy")
Dim colItems As ManagementObjectCollection = objWMIService.Get()

' ListView mit Daten füllen
For Each objItem As ManagementObject In colItems
Dim item As New ListViewItem(objItem("Name").ToString())
item.SubItems.Add(objItem("BytestransmittedPersec" ).ToString())
item.SubItems.Add(objItem("PacketstransmittedPerse c").ToString())
item.SubItems.Add(objItem("PacketsdroppedPersec"). ToString())

QoSData.Items.Add(item)
Next
End Function
'item.SubItems.Add(objItem("Timestamp_Object").ToS tring())
'item.SubItems.Add(objItem("Timestamp_PerfTime").T oString())
'item.SubItems.Add(objItem("Timestamp_Sys100NS").T oString())
'item.SubItems.Add(objItem("Description").ToString ())
'item.SubItems.Add(objItem("Caption").ToString())
' item.SubItems.Add(objItem("Bytestransmitted").ToSt ring())
' item.SubItems.Add(objItem("Frequency_Object").ToSt ring())
' item.SubItems.Add(objItem("Frequency_PerfTime").To String())
' item.SubItems.Add(objItem("Frequency_Sys100NS").To String())
'item.SubItems.Add(objItem("Packetsdropped").ToStr ing())
'item.SubItems.Add(objItem("Packetstransmitted").T oString())
End Class