|
Option Explicit
Private Const VER_SUITE_PERSONAL As Long = &H200&
Private Const VER_PLATFORM_WIN32s As Long = 0&
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1&
Private Const VER_PLATFORM_WIN32_NT As Long = 2&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const MAX_COMPUTERNAME_LENGTH = 15
Private Const WS_VERSION_REQD As Long = &H101&
Private Const MIN_SOCKETS_REQD As Long = 1&
Private Const SOCKET_ERROR As Long = -1&
Private Const WSADescription_Len As Long = 256&
Private Const WSASYS_Status_Len As Long = 128&
Private m_bAlreadyGot As Boolean
Private m_OsVersion As WindowsVersion
Private Declare Function GetVersionEx1 Lib "kernel32.dll" Alias _
"GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) _
As Long
Private Declare Function GetVersionEx2 Lib "kernel32.dll" Alias _
"GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFOEX) _
As Long
Private Declare Function GetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) _
As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias _
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias _
"RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpName As String, lpcbName As Long, ByVal lpReserved _
As Long, ByVal lpClass As String, lpcbClass As Long, _
lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias _
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal _
lpReserved As Long, lpType As Long, lpData As Any, lpcbData _
As Long) As Long
Private Declare Sub GlobalMemoryStatus Lib "kernel32" ( _
lpBuffer As MEMORYSTATUS)
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal _
HostName As String, ByVal HostLen As Integer) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _
HostName As String) As Long
Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" (ByVal _
addr As String, ByVal laenge As Integer, ByVal typ As Integer) _
As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () _
As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired As Long, lpWSAData As WinSocketDataType) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _
ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Type WinSocketDataType
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private Type HostDeType
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type OSVERSIONINFOEX
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
wServicePackMajor As Integer
wServicePackMinor As Integer
wSuiteMask As Integer
wProductType As Byte
wReserved As Byte
End Type
Public Enum WindowsVersion
WIN_OLD
WIN_95
WIN_98
WIN_ME
WIN_NT_3x
WIN_NT_4x
WIN_2K
WIN_XP
WIN_XP_HOME
WIN_2003
End Enum
Private Sub cmdProzessordatenAuslesen_Click()
Dim Prozessor As String
Dim Familie As String
Dim Speicher As Long
Dim Rueck As Long
Dim Puffer As Long
Dim User As String
Dim Computername As String
Dim IPAdresse As String * 15
Dim WindowsVersion As String
Dim ServicePack As String
Puffer = 255
User = Space$(Puffer)
Rueck = GetUserName(User, Puffer)
If Rueck <> 0 Then
User = Left(User, Puffer - 1)
Else
User = "nicht ermittelbar"
End If
Call Prozessordaten(Prozessor, Familie)
Call Arbeitsspeicher(Speicher)
Call ComputerUsernamenErmitteln(Computername)
IPAdresse = GetIP(Computername)
WindowsVersion = ErmittleWVers
ServicePack = ErmittleSP
MsgBox Prozessor & _
vbCrLf & Familie & vbCrLf & _
vbCrLf & "Arbeitsspeicher: " & vbTab & vbTab & _
Speicher & " MB" & _
vbCrLf & "Angemeldeter User: " & vbTab & User & _
vbCrLf & "Computername: " & vbTab & vbTab & Computername & _
vbCrLf & "IP-Adresse: " & vbTab & vbTab & IPAdresse & _
vbCrLf & "Betriebssystem: " & vbTab & vbTab & _
WindowsVersion & _
vbCrLf & "Service-Pack: " & vbTab & vbTab & ServicePack, _
vbOKOnly, "Rechnerdaten auslesen"
End Sub
Private Sub CleanSockets()
Dim Result As Long
Result = WSACleanup()
If Result <> 0 Then
Call MsgBox("Socket Error " & Trim$(Str$(Result)) & _
" in Prozedur 'CleanSockets' aufgetreten !")
End
End If
End Sub
Sub Prozessordaten(Prozessor, Familie)
Dim hKey As Long, Cnt As Long, sName As String, sData As String
Dim Retour As Long, RetData As Long
Const BUFFER_SIZE As Long = 255
Cnt = 0
If RegOpenKey(HKEY_LOCAL_MACHINE, _
"HARDWARE\DESCRIPTION\System\CentralProcessor\0\", hKey) = 0 _
Then
While RegEnumValue(hKey, Cnt, sName, Retour, 0, ByVal 0&, _
ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS
If LCase$(Left$(sName, 10)) = "identifier" Then _
Familie = Trim$(Left$(sData, RetData - 1))
If UCase$(Left$(sName, 13)) = "PROCESSORNAME" Then _
Prozessor = Trim$(Left$(sData, RetData - 1))
Cnt = Cnt + 1
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Retour = BUFFER_SIZE
RetData = BUFFER_SIZE
Wend
RegCloseKey hKey
End If
End Sub
Public Function ErmittleSP()
Dim hKey As Long, Cnt As Long, sName As String, sData As String
Dim Retour As Long, RetData As Long
Const BUFFER_SIZE As Long = 255
Cnt = 0
If RegOpenKey(HKEY_LOCAL_MACHINE, _
"SOFTWARE\Microsoft\Windows NT\CurrentVersion", hKey) = 0 Then
While RegEnumValue(hKey, Cnt, sName, Retour, 0, ByVal 0&, _
ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS
If LCase$(Left$(sName, 10)) = "csdversion" Then _
ErmittleSP = Trim$(Left$(sData, RetData - 1))
Cnt = Cnt + 1
sName = Space(BUFFER_SIZE)
sData = Space(BUFFER_SIZE)
Retour = BUFFER_SIZE
RetData = BUFFER_SIZE
Wend
RegCloseKey hKey
End If
End Function
Function ErmittleWVers()
Select Case GetOSVersion
Case WIN_OLD: ErmittleWVers = "Windows 32s"
Case WIN_95: ErmittleWVers = "Windows 95"
Case WIN_98: ErmittleWVers = "Windows 98"
Case WIN_ME: ErmittleWVers = "Windows ME"
Case WIN_NT_3x: ErmittleWVers = "Windows NT 3"
Case WIN_NT_4x: ErmittleWVers = "Windows NT 4"
Case WIN_2K: ErmittleWVers = "Windows 2000"
Case WIN_XP: ErmittleWVers = "Windows XP professional"
Case WIN_XP_HOME: ErmittleWVers = "Windows XP Home Edition"
Case WIN_2003: ErmittleWVers = "Windows 2003"
Case Else: ErmittleWVers = "*unknown*"
End Select
End Function
Public Function GetOSVersion() As WindowsVersion
Dim OsVersInfoEx As OSVERSIONINFOEX
Dim OsVersInfo As OSVERSIONINFO
If m_bAlreadyGot Then
GetOSVersion = m_OsVersion
Exit Function
End If
OsVersInfo.dwOSVersionInfoSize = Len(OsVersInfo)
If GetVersionEx1(OsVersInfo) = 0 Then
MsgBox "Das Betriebssystem konnte nicht korrekt erkannt " & _
"werden:" & vbCrLf & "Fehler im API-Aufruf"
m_OsVersion = WIN_OLD
Exit Function
End If
With OsVersInfo
Select Case .dwPlatformId
Case VER_PLATFORM_WIN32s
m_OsVersion = WIN_OLD
Case VER_PLATFORM_WIN32_WINDOWS
Select Case .dwMinorVersion
Case 0
m_OsVersion = WIN_95
Case 10
m_OsVersion = WIN_98
Case 90
m_OsVersion = WIN_ME
End Select
Case VER_PLATFORM_WIN32_NT
Select Case .dwMajorVersion
Case 3
m_OsVersion = WIN_NT_3x
Case 4
m_OsVersion = WIN_NT_4x
Case 5
Select Case .dwMinorVersion
Case 0
m_OsVersion = WIN_2K
Case 1
OsVersInfoEx.dwOSVersionInfoSize = _
Len(OsVersInfoEx)
If GetVersionEx2(OsVersInfoEx) = 0 Then
MsgBox "Das Betriebssystem konnte nicht " & _
"korrekt erkannt werden:" & _
vbCrLf & "Fehler im API-Aufruf"
m_OsVersion = WIN_XP
Exit Function
End If
If (OsVersInfoEx.wSuiteMask And _
VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL Then
m_OsVersion = WIN_XP_HOME
Else
m_OsVersion = WIN_XP
End If
Case 2
m_OsVersion = WIN_2003
End Select
End Select
End Select
End With
GetOSVersion = m_OsVersion
m_bAlreadyGot = True
End Function
Public Function GetIP(Computername As String)
Dim IP As String
Dim x As Integer
Dim Result As Integer
Dim SocketData As WinSocketDataType
Result = WSAStartup(WS_VERSION_REQD, SocketData)
GetIP = HostByName(Computername, x)
Result = WSACleanup()
End Function
Private Function HostByName(Name As String, _
Optional x As Integer = 0) As String
Dim MemIp() As Byte
Dim y As Integer
Dim HostDeAddress As Long, HostIp As Long
Dim sIPAdr As String
Dim Host As HostDeType
HostDeAddress = gethostbyname(Name)
Call RtlMoveMemory(Host, HostDeAddress, LenB(Host))
For y = 0 To x
Call RtlMoveMemory(HostIp, Host.hAddrList + 4 * y, 4)
If HostIp = 0 Then
HostByName = ""
Exit Function
End If
Next y
ReDim MemIp(1 To Host.hLength)
Call RtlMoveMemory(MemIp(1), HostIp, Host.hLength)
sIPAdr = ""
For y = 1 To Host.hLength
sIPAdr = sIPAdr & MemIp(y) & "."
Next y
sIPAdr = Left$(sIPAdr, Len(sIPAdr) - 1)
HostByName = sIPAdr
End Function
Sub ComputerUsernamenErmitteln(Computername)
Dim sPuffer As String
Dim Result As Long
Dim L As Long
Dim lngPuffer As Long
Dim lngErgebnis As Long
L = MAX_COMPUTERNAME_LENGTH + 1
sPuffer = Space$(L)
Result = GetComputerName(sPuffer, L)
If Result = 1 Then
Computername = Left$(sPuffer, InStr(1, sPuffer, Chr$(0)) - 1)
Else
Computername = "(unknown)"
End If
End Sub
Sub Arbeitsspeicher(Speicher As Long)
Dim Memory As MEMORYSTATUS
Memory.dwLength = Len(Memory)
Call GlobalMemoryStatus(Memory)
Speicher = Format((Memory.dwTotalPhys / 1048576), "0")
End Sub
|
|