Unser heutiger Tipp zeigt, wie sich mit Hilfe von WMI alle LAN-Verbindungen deaktivieren lassen, deren Netzwerkkarten nicht verbunden sind. Option Explicit ' benötigte API-Deklaration Private Declare Function WaitForSingleObject Lib "kernel32" ( _ ByVal hHandle As Long, _ ByVal dwMilliseconds As Long) As Long ' LAN-Verbindungen deaktivieren Public Sub DeactivateLAN() Const ssfCONTROLS = 3 Const HKEY_LOCAL_MACHINE = &H80000002 Dim objWMIService As Variant Dim colAdapters As Variant Dim objAdapter As Variant Dim colAdapters2 As Variant Dim oReg As Variant Dim shellApp As Variant Dim oControlPanel As Variant Dim oNetConnections As Variant Dim oLanConnection As Variant Dim folderitem As Variant Dim oDisableVerb As Variant Dim Verb As Variant Dim strMACaddress(9) Dim strSettingID(9) Dim strComputer As String Dim sDisableVerb As String Dim sConnectionName As String Dim i As Long Dim strKeyPath As String Dim strValueName As String Dim bEnabled As Boolean strComputer = "." sDisableVerb = "&Deaktivieren" ' Hier werden alle Adapter ermittelt, die nicht verbunden sind Set objWMIService = GetObject _ ("winmgmts:" & "!\\" & strComputer & "\root\cimv2") Set colAdapters = objWMIService.ExecQuery _ ("Select * from Win32_NetworkAdapter Where NetConnectionStatus = 7") ' MAC-Adresse ermitteln i = 0 For Each objAdapter In colAdapters If Not IsNull(objAdapter.MACAddress) Then strMACaddress(i) = objAdapter.MACAddress i = i + 1 End If Next If i = 0 Then ' kein verbindungsloser Netzwerk-Adapter gefunden MsgBox "keine verbindungslose Netzwerk-Adapter gefunden!" Exit Sub End If ' Hier wird die SettingID(i) der Netzwerkkarte herausgefunden, ' die nicht verbunden ist Set objWMIService = GetObject _ ("winmgmts:" & "!\\" & strComputer & "\root\cimv2") Set colAdapters2 = objWMIService.ExecQuery _ ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = TRUE") For Each objAdapter In colAdapters2 For i = 0 To UBound(strMACaddress) If objAdapter.MACAddress = strMACaddress(i) Then strSettingID(i) = objAdapter.SettingID End If ' Hier wird der Registry-Key zusammengebaut, ' der ausgelesen werden soll strKeyPath = "SYSTEM\CurrentControlSet\Control\Network\" & _ "{4D36E972-E325-11CE-BFC1-08002BE10318}\" & _ strSettingID(i) & _ "\Connection" ' Setzen von Variablen Set oReg = GetObject("winmgmts:" & "!\\" & strComputer & _ "\root\default:StdRegProv") strValueName = "Name" ' Hier wird der Name (ExpandedString) der LAN-Verbindung ' aus der Registry gelesen oReg.GetExpandedStringValue HKEY_LOCAL_MACHINE, strKeyPath, _ strValueName, sConnectionName ' Setzen von Variablen Set shellApp = CreateObject("shell.application") Set oControlPanel = shellApp.Namespace(ssfCONTROLS) Set oNetConnections = Nothing Set oLanConnection = Nothing ' Hier sucht das Programm einen Ordner der Netzwerkverbindung heißt For Each folderitem In oControlPanel.items If folderitem.Name = "Netzwerkverbindungen" Then Set oNetConnections = folderitem.getfolder: Exit For End If Next ' Wenn es keinen gefunden hat dann Fehlermeldung If oNetConnections Is Nothing Then MsgBox "Finde den Ordner Netzwerkverbindungen nicht !!" Exit Sub End If ' Hier vergleicht das Programm LAN-Verbindungen aus der ' Registry mit denen im Ordner Netzwerkverbindungen For Each folderitem In oNetConnections.items If LCase(folderitem.Name) = LCase(sConnectionName) Then Set oLanConnection = folderitem: Exit For End If Next ' Wenn es keine identischen LAN-Verbindungen gefunden hat ' dann Fehlermeldung If oLanConnection Is Nothing Then MsgBox "Finde folgende Lan-Verbindung nicht: " & sConnectionName & "item" Exit Sub End If ' Hier wird die LAN-Verbindung im Netzwerkordner auf ' deaktiviert gesetzt bEnabled = True Set oDisableVerb = Nothing For Each Verb In oLanConnection.verbs If Verb.Name = sDisableVerb Then Set oDisableVerb = Verb End If Next If bEnabled Then oDisableVerb.DoIt ' kurze Pause (5 Sekunden) Sleep 5000 Next Next End Sub ' Ewartet wird die Zeitangabe in Millisekunden! ' z.B. 1000 für 1 Sekunde Public Function Sleep(ByVal mSek As Long) WaitForSingleObject -1, mSek End Function Dieser Tipp wurde bereits 26.046 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
TOP! Unser Nr. 1 Neu! sevDataGrid 3.0 Mehrspaltige Listen, mit oder ohne DB-Anbindung. Autom. Sortierung, Editieren von Spalteninhalten oder das interaktive Hinzufügen von Datenzeilen sind ebenso möglich wie das Erstellen eines Web-Reports. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |