Manchmal ist es interessant mehr über Rechner im Netzwerk zu erfahren. Folgender Code ermittelt anhand des Computernamens die IP-Adresse, das Betriebssystem, die Domain, das Root-Verzeichnis (nur Win9x), die Winsock Version und die Anzahl der eingeloggten User. ' Die nötigen Konstanten Typ- und ' Funktionsdeklarationen für die API-Aufrufe Private Const MIN_SOCKETS_REQD As Long = 1 Private Const WS_VERSION_REQD As Long = &H101 Private Const WS_VERSION_MAJOR As Long = _ WS_VERSION_REQD \ &H100 And &HFF& Private Const WS_VERSION_MINOR As Long = _ WS_VERSION_REQD And &HFF& Private Const ERROR_SUCCESS = 0& Private Const MAX_WSADescription = 256 Private Const MAX_WSASYSStatus = 128 Private Const PLATFORM_ID_DOS = 300 Private Const PLATFORM_ID_OS2 = 400 Private Const PLATFORM_ID_NT = 500 Private Const PLATFORM_ID_OSF = 600 Private Const PLATFORM_ID_VMS = 700 Private Type WSAData wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Private Type WKSTA_INFO_102 wki100_platform_id As Long pwki100_computername As Long pwki100_langroup As Long wki100_ver_major As Long wki100_ver_minor As Long pwki102_lanroot As Long wki102_logged_on_users As Long End Type Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Declare Function WSAStartup Lib "WSOCK32" ( _ ByVal wVersionRequired As Long, _ lpWSADATA As WSAData) As Long Declare Function WSACleanup Lib "WSOCK32" () As Long Declare Function NetWkstaGetInfo Lib "netapi32" ( _ ByVal servername As String, _ ByVal level As Long, _ lpBuf As Any) As Long Private Declare Function NetApiBufferFree Lib "netapi32" ( _ ByVal Buffer As Long) As Long Declare Function gethostbyname Lib "WSOCK32" ( _ ByVal szHost As String) As Long Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" ( _ hpvDest As Any, _ ByVal hpvSource As Long, _ ByVal cbCopy As Long) Dim WSAD As WSAData ' Zu übergeben ist der Computername inkl. vorangestellten ' "\\", also z.B. "\\PCTest" ' Zurückgelifert wird ein String, in dem die Werte per ' vbCrLf getrennt sind Public Function GetComputerInfo(ByVal strComputername As _ String) As String Dim lpHost As Long Dim m_Host As HOSTENT Dim lIP As Long Dim tmpIP() As Byte Dim i As Integer Dim strIP As String Dim strErgebnis As String Dim strTemp As String ' Winsock initialisieren If Not SocketsInitialize() Then Exit Function ' ==================================================== ' IP-ADRESSE DES COMPUTERS ERMITTELN ' ' Anschliessend die Daten holen und für VB zugänglich ' machen ' Zuerst kümmern wir uns um die IP-Adresse lpHost = gethostbyname(ByVal Replace(strComputername, _ "\", "")) If lpHost = 0 Then Exit Function CopyMemory m_Host, ByVal lpHost, ByVal Len(m_Host) ' erst die Adresse in eine Longvariable kopieren CopyMemory lIP, ByVal m_Host.hAddrList, ByVal 4 ' und dann Stück für Stück in ein Bytefeld ReDim tmpIP(1 To m_Host.hLen) CopyMemory tmpIP(1), ByVal lIP, ByVal m_Host.hLen ' Das Bytefeld in einen String umwandeln For i = 1 To m_Host.hLen strIP = strIP & tmpIP(i) & "." Next ' aber den letzten Punkt weglassen strErgebnis = "IP-Adresse: " & Mid$(strIP, 1, _ Len(strIP) - 1) & vbCrLf ' ' ==================================================== ' Wir wollen auch die Winsock Daten haben ' (weil Sie da sind;-)) With WSAD ' Winsock-Version For i = LBound(.szDescription) To UBound(.szDescription) If .szDescription(i) <> 0 Then strTemp = strTemp & Chr$(.szDescription(i)) Else Exit For End If Next i strErgebnis = strErgebnis & "Winsock Version: " & _ strTemp & vbCrLf strTemp = "" ' Winsock-Status For i = LBound(.szSystemStatus) To UBound(.szSystemStatus) If .szSystemStatus(i) <> 0 Then strTemp = strTemp & Chr$(WSAD.szSystemStatus(i)) Else Exit For End If Next i strErgebnis = strErgebnis & "Winsock Status: " & _ strTemp & vbCrLf End With ' Ab hier sind wir mit Winsock fertig und räumen auf SocketsCleanup ' Nun geht es an die Netzwerkdaten eines Computer Dim pWrkInfo As Long Dim WrkInfo(0) As WKSTA_INFO_102 Dim lResult As Long lResult = NetWkstaGetInfo(StrConv(strComputername, _ vbUnicode), 102, pWrkInfo) If lResult = 0 Then Dim cname As String cname = String$(255, 0) CopyMemory WrkInfo(0), ByVal pWrkInfo, _ ByVal Len(WrkInfo(0)) CopyMemory ByVal cname, _ ByVal WrkInfo(0).pwki100_langroup, ByVal 255 strErgebnis = strErgebnis & "Domain: " & _ StripTerminator(StrConv(cname, vbFromUnicode)) & _ vbCrLf strErgebnis = strErgebnis & "Betriebssystem: " Select Case WrkInfo(0).wki100_platform_id Case PLATFORM_ID_DOS strErgebnis = strErgebnis & "DOS" Case PLATFORM_ID_OS2 If WrkInfo(0).wki100_ver_major = "4" Then strErgebnis = strErgebnis & "Win9x" Else strErgebnis = strErgebnis & "OS2" End If Case PLATFORM_ID_NT If WrkInfo(0).wki100_ver_major = "5" Then strErgebnis = strErgebnis & "Win 2000" Else strErgebnis = strErgebnis & "NT" End If Case PLATFORM_ID_OSF strErgebnis = strErgebnis & "OSF" Case PLATFORM_ID_VMS strErgebnis = strErgebnis & "VMS" End Select strErgebnis = strErgebnis & " Version " & _ WrkInfo(0).wki100_ver_major & "." & _ WrkInfo(0).wki100_ver_minor cname = String$(255, 0) CopyMemory ByVal cname, _ ByVal WrkInfo(0).pwki102_lanroot, ByVal 255 strErgebnis = strErgebnis & "Lan Root: " & _ StripTerminator(StrConv(cname, vbFromUnicode)) strErgebnis = strErgebnis & "Eingeloggte Benutzer: " & _ Str$(WrkInfo(0).wki102_logged_on_users) ' Nach einem erfolgreichen NetWkstaGetInfo den ' benutzten API-Buffer wieder freigeben NetApiBufferFree ByVal pWrkInfo End If GetComputerInfo = strErgebnis End Function ' Dieser Teil stammt aus dem Programm API-Guide ' KPD-Team 1999 ' URL: http://www.allapi.net/ ' E-Mail: KPDTeam@Allapi.net Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Sub SocketsCleanup() If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket Fehler in Cleanup" End If End Sub Private Function SocketsInitialize() As Boolean Dim sLoByte As String Dim sHiByte As String ' Prüfen, ob Winsock.DLL vorhanden If WSAStartup(WS_VERSION_REQD, WSAD) <> _ ERROR_SUCCESS Then MsgBox "Programm konnte keine funktionsfähige " & _ "Winsock.DLL finden" SocketsInitialize = False Exit Function End If ' nicht genügend Sockets If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then MsgBox "Das Programm muß mindestens " & _ CStr(MIN_SOCKETS_REQD) & _ " Sockets öffnen können." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _ (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _ HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then sHiByte = CStr(HiByte(WSAD.wVersion)) sLoByte = CStr(LoByte(WSAD.wVersion)) MsgBox "Die Socket Version " & sLoByte & "." & _ sHiByte & " wird nicht unterstützt." SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function ' Diese Funktion erleichtert einen VB-String um ' Chr$(0) am Ende Private Function StripTerminator(sInput As String) As _ String Dim ZeroPos As Integer ZeroPos = InStr(1, sInput, vbNullChar) If ZeroPos > 0 Then StripTerminator = Left$(sInput, ZeroPos - 1) Else StripTerminator = sInput End If End Function Dieser Tipp wurde bereits 57.024 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. |
sevAniGif (VB/VBA) Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |