Display Microsoft System Information

Category:

System/API

Type:

Snippets

Difficulty:

Intermediate

Author:

Ali Ezzahir

Version Compatibility:

More information:

Good to add to an about box, or any other place in the app where you need to display detailed information about the system.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
'Name: Ali ezzahir 'Winnipeg , Manitoba, Canada 'http://www.geocities/athens/aegean/6647 'http://www.geocities/athens/troy/3164 Option Explicit Const KEY_ALL_ACCESS = &H2003F Const HKEY_LOCAL_MACHINE = &H80000002 Const ERROR_SUCCESS = 0 Const REG_SZ = 1 Const REG_DWORD = 4 Const gREGKEYSYSINFOLOC = _ "SOFTWARE\Microsoft\Shared Tools Location" Const gREGVALSYSINFOLOC = "MSINFO" Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO" Const gREGVALSYSINFO = "PATH" Private Declare Function RegOpenKeyEx Lib "advapi32" _ Alias "RegOpenKeyExA" (ByVal HKey As Long, _ ByVal lpSubKey As String, ByVal ulOptions As Long, _ ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" _ Alias "RegQueryValueExA" (ByVal HKey As Long, _ ByVal lpValueName As String, ByVal lpReserved As Long, _ ByRef lpType As Long, ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32" _ (ByVal HKey As Long) As Long

Code:

Public Sub StartSysInfo()
    On Error GoTo SysInfoErr
        Dim rc As Long
        Dim SysInfoPath As String
        
        If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, _
            gREGVALSYSINFO, SysInfoPath) Then
        
        ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, _
         gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
                
              If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
                    SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
                    
                Else
                     GoTo SysInfoErr
                End If

Else
                GoTo SysInfoErr
        End If

Call Shell(SysInfoPath, vbNormalFocus)

Exit Sub

SysInfoErr:
MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub

Private Function GetKeyValue(KeyRoot As Long, _
   KeyName As String, SubKeyRef As String, _
   ByRef KeyVal As String) As Boolean
 
        Dim i As Long
        Dim rc As Long
        Dim HKey As Long
        Dim hDepth As Long
        Dim KeyValType As Long
        Dim tmpVal As String
        Dim KeyValSize As Long
       
        rc = RegOpenKeyEx(KeyRoot, KeyName, 0, _
           KEY_ALL_ACCESS, HKey)

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError

tmpVal = String$(1024, 0)
        KeyValSize = 1024

'------------------------------------------------------
        ' Retrieve Registry Key Value...
        '------------------------------------------------------
        rc = RegQueryValueEx(HKey, SubKeyRef, 0, _
          KeyValType, tmpVal, KeyValSize)

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
                tmpVal = Left(tmpVal, KeyValSize - 1)
        Else
                tmpVal = Left(tmpVal, KeyValSize)
        End If
        
        Select Case KeyValType
        Case REG_SZ
                KeyVal = tmpVal
        Case REG_DWORD
                For i = Len(tmpVal) To 1 Step -1
                   KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))
                Next
                KeyVal = Format$("&h" + KeyVal)
        End Select

GetKeyValue = True
        rc = RegCloseKey(HKey)
        Exit Function

GetKeyError:
        KeyVal = ""
        GetKeyValue = False
        rc = RegCloseKey(HKey)
End Function