Tipp 0522 Rechnerdaten auslesen
Autor/Einsender:
Datum:
  Lothar Kriegerow
07.11.2006
Entwicklungsumgebung:   VB 6
Mit Hilfe von einem guten Dutzend API-Funktionen sowie den entsprechenden Konstanten, lässt auch mit VB der Prozessorname und -typ, die lokale IP-Adresse, der Arbeitsspeicher (RAM), der Computer- und Anmeldename und das Service-Pack auf Rechnern ab Windows 2000 auslesen.
Der Tipp wurde so konzipiert, dass jede Funktion auch einzeln lauffähig ist und problemlos in andere Anwendungen integriert werden kann, da die Daten als Variablen übergeben werden, so dass sie problemlos auch anderen Programmteilen zur Verfügung stehen können.
 
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
 
Hinweis für VBA-Anwender
Der hier abgebildete Code funktioniert auch in einem VBA-Projekt (ab Office 2000 !). Die im Download enthaltene *.frm-Datei kann beispielsweise in Notepad geöffnet werden, und der kommentierte Code über die Zwischenablage in das VBA-Projekt kopiert werden. Ein Import der im Download enthaltenen *.frm-Datei ist nicht möglich.
Weitere Links zum Thema
Aktuelles Betriebssystem ermitteln
Anzahl der Prozessoren ermitteln
Computername ermitteln
CPU-Daten ermitteln (WMI)

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5,8 kB) Downloads bisher: [ 160 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 15. Mai 2011