Get Windows 98 registry values, VB6

Hi Everyone

Before I start I have to say this is an excellent forum for VBA/VB6 help - I'm a novice VB programmer but I often come here with issues and find the answers without making a post. This time I have an issue for which I haven't found an answer.

I have a VB6 project that extracts information from the users PC and it works well on Windows XP but it doesn't work on Windows 98 PC's. Part of the process involves extracting information from the registry using these commands :

Code:

---

Public Function GetInfo()
        Dim oWSH As Object
        Set oWSH = CreateObject("WScript.Shell")
        GetInfo = oWSH.RegRead("HKEY_LOCAL_MACHINE\...")
        'the previous line was truncated for the sake of brevity
End Function

---

As I mentioned, this works fine on XP PC's but fails on Windows 98 PC's (and I suspect it would also fail on Win 95 & ME). I have checked the registry and the identical path I'm seeking exists on the 98 PC, so I suspect the issue is with the "WScript.Shell" line.

How can this line (or code) be modified to accommodate other versions of Windows?

TIA, Andrew :)

P.S. I'm posting now from the '98 PC and I forgot to mention that the error is number 429 : "ActiveX component can't create object".

Hi Andrew93,
FYI:
The version of WSH (Windows Script Host) in Windows 98, 2000,
and Millennium Editions is either version 1.0 or 2.0.

You can upgrade to version 5.6 by going to:
http://www.microsoft.com/downloads/d...DisplayLang=en

If an upgrade is not possible maybe this thread can help:
http://www.vbaexpress.com/forum/showthread.php?t=5974

HTH,

Marcster.

Hi Andrew,

You can also do this using APIs. I have the following module I use whenever I have to work with the registry. I didn't write it, but I do use it if you have any questions. I have the following module that I import into my registry-based projects:

Code:

---

Option Explicit
'Attribute VB_Name = "modRegistry"
' modRegistry.Bas - Declares, Subroutines and Functions for the Registry
' 1997/05/03 Copyright 1994-1997, Larry Rebich, The Bridge, Inc.
'' Functions and Subroutines included in this module:
''  Function RegRead    Returns a value using the Supplied Key and Value Name
'  Function RegWrite  Write a value using the Supplied Key, Value Name and Value
'                      Remove the Value Name if value is null [""]
'  Function RegCreate  Create a Key, open the Key, then close the Key.
'                      This function is called by RegWrite if the key does not exist.
'                      There should be no reason to call this function directly.
' Only string data [REG_SZ] is process by these routines.
' For details see the comments associated with each function.
'
DefLng A-Z
Public Const REG_SZ        As Long = 1
Public Const REG_DWORD      As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKCR = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKCU = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKLM = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKU = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_FILE_NOT_FOUND& = 2
Public Const ERROR_SUCCESS& = 0
Public Const NO_ERROR& = 0
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or _
 KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const REG_OPTION_NON_VOLATILE = 0&
Public Const REG_CREATED_NEW_KEY& = 1
Public Const REG_OPENED_EXISTING_KEY& = 2
Private Type FILETIME
 dwLowDateTime          As Long
 dwHighDateTime          As Long
End Type
Private Type SECURITY_ATTRIBUTES
 nLength                As Long
 lpSecurityDescription  As Long  'SECURITY_DESCRIPTOR
 bInheritHandle          As Boolean
End Type
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
lpdwDisposition As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpValueName As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Function RegCreate(sKey As String, Optional lngHKey As Long) As Long
  '/Purpose:
  '/Created: 11/6/2003 10:56 PM
  '/Created By: Scott
  ' Create a key
  ' Returns:
  '    False if Fails to Create the Key
  ' or lDisposition:
  '    REG_CREATED_NEW_KEY& = 1& or  'created a new key
  '    REG_OPENED_EXISTING_KEY& = 2&  'key already exists
  '
  Dim lRtn                      As Integer
  Dim lHKey                    As Long          'return handle to opened key
  Dim lDisposition              As Long    'disposition
  Dim lpSecurityAttributes      As SECURITY_ATTRIBUTES
  On Error GoTo Err_RegCreate
  If lngHKey <> 0 Then
    lRtn = RegCreateKeyEx(lngHKey, sKey, 0&, "", REG_OPTION_NON_VOLATILE, KEY_WRITE, _
    lpSecurityAttributes, lHKey, lDisposition)
    Else
    lRtn = RegCreateKeyEx(HKEY_CURRENT_USER, sKey, 0&, "", _
    REG_OPTION_NON_VOLATILE, KEY_WRITE, lpSecurityAttributes, lHKey, lDisposition)
  End If
    If lRtn = ERROR_SUCCESS Then
    RegCreate = lDisposition    'tell 'em if it existed or was created
    lRtn = RegCloseKey(lHKey)  'close the Registry
    End If 'If lRtn = ERROR_SUCCESS
Exit_RegCreate:
  On Error Resume Next
  Exit Function
Err_RegCreate:
    Select Case Err.Number
    Case Else
        ErrorHandler Err.Number, Err.Description, "RegCreate_basReg"
    End Select
  Resume Exit_RegCreate
End Function

Public Function RegRead(sKey As String, sValueName As String, Optional _
 vntOptionalHKey As Variant) As String
  '/Purpose:
  '/Created: 11/6/2003 10:56 PM
  '/Created By: Scott
  ' Returns the Value found for this Key and ValueName
  ' Input:        Sample:
  '  sKey        "Software\Microsoft\File Manager\Settings"
  '  sValueName  "Face"
  ' Return:
  '              "FixedSys" or
  '              "" [null] if not found
  ' 96/09/18 Add support for different root level key. Needed to find DAO3032.DLL
  ' in class registry. Larry.
  Dim lOptionalHKey            As Long  '96/09/18 Can open a different area key.
  Dim lKeyType                  As Long
  Dim lHKey                    As Long      'return handle to opened key
  Dim lpcbData                  As Long    'length of data in returned string
  Dim sReturnedString          As String  'returned string value
  Dim sTemp                    As String    'temp string
  Dim lRtn                      As Long        'success or not success
  On Error GoTo Err_RegRead
  If IsMissing(vntOptionalHKey) Then
    lOptionalHKey = HKEY_CURRENT_USER  'Use current user
    Else
    lOptionalHKey = vntOptionalHKey    'Use the one supplied
  End If 'If IsMissing(vntOptionalHKey)
  lKeyType = REG_SZ      'data type is string
  lRtn = RegOpenKeyEx(lOptionalHKey, sKey, 0&, KEY_READ, lHKey)
    If lRtn = ERROR_SUCCESS Then
    lpcbData = 1024                    'get this many characters
    sReturnedString = Space$(lpcbData)  'setup the buffer
    lRtn = RegQueryValueEx(lHKey, sValueName, ByVal 0&, lKeyType, _
    sReturnedString, lpcbData)
    If lRtn = ERROR_SUCCESS Then
        sTemp = Left$(sReturnedString, lpcbData - 1)
    End If 'If lRtn = ERROR_SUCCESS
    RegCloseKey lHKey
    End If 'If lRtn = ERROR_SUCCESS
  RegRead = sTemp
Exit_RegRead:
  On Error Resume Next
  Exit Function
Err_RegRead:
    Select Case Err.Number
    Case Else
    ErrorHandler Err.Number, Err.Description, "RegRead_basReg"
    End Select
  Resume Exit_RegRead
End Function

Function ErrorHandler(ByVal errNum As Long, ByVal errDesc As String, _
  Optional ByVal ExtraText As String) As Boolean
 MsgBox "Error number: " & errNum & vbCrLf & _
  "Description: " & errDesc & vbCrLf & ExtraText, vbCritical, "Error!"
End Function

Public Function RegWrite(sKey As String, sValueName As String, ByVal _
 sValue As String, Optional vntOptionalHKey As Variant) As Integer
  '/Purpose:
  '/Created: 11/6/2003 10:56 PM
  '/Created By: Scott
  ' Input:        Sample:
  '  sKey        "Software\Microsoft\File Manager\Settings"
  '  sValueName  "Face"
  '  sValue      "FixedSys"
  ' Return:
  '  True if successful
' If the current setting is the same as the new setting then the update
  ' is bypassed.
' Note: If sValue = "" then sValueName is removed [deleted].
  '-----------------------------------------------------------------------------------
  Dim lOptionalHKey As Long  '10/14/96 Can open a different area key(to register fonts). Boris
  Dim lRtn          As Long
  Dim lKeyType      As Long 'returns the key type.  This function expects REG_SZ
  Dim lHKey        As Long 'return handle to opened key
  Dim iSuccessCount As Integer
  On Error GoTo Err_RegWrite
  lKeyType = REG_SZ      'these routines support only string types
    If IsMissing(vntOptionalHKey) Then
    lOptionalHKey = HKEY_CURRENT_USER  'Use current user
    Else
    lOptionalHKey = vntOptionalHKey    'Use the one supplied
    End If 'If IsMissing(vntOptionalHKey)
    If Trim$(sValue) <> "" Then            'if there is a value then update it
    RegWriteTryAgain:
    lRtn = RegOpenKeyEx(lOptionalHKey, sKey, 0&, KEY_SET_VALUE, lHKey)  'open the Registry
    If lRtn = ERROR_SUCCESS Then
        lRtn = RegSetValueEx(lHKey, sValueName, 0&, lKeyType, ByVal sValue, _
        CLng(Len(sValue) + 1))  'update the value
        If lRtn = ERROR_SUCCESS Then
            iSuccessCount = iSuccessCount + 1
        End If 'If lRtn = ERROR_SUCCESS
        lRtn = RegCloseKey(lHKey)      'close the Registry
        ElseIf lRtn = ERROR_FILE_NOT_FOUND Or lRtn = ERROR_BADKEY Then 'create it
        If RegCreate(sKey, lOptionalHKey) Then        'Create it, was it successful?
            GoTo RegWriteTryAgain      'Yes, go try writing again
        End If 'If RegCreate(sKey)
    End If 'If lRtn = ERROR_SUCCESS
    Else                                    'Value is null, delete the key
    lRtn = RegOpenKeyEx(lOptionalHKey, sKey, 0&, KEY_SET_VALUE, lHKey)  'open the Registry
    If lRtn = ERROR_SUCCESS Then
        lRtn = RegDeleteValue(lHKey, sValueName)
        If lRtn = ERROR_SUCCESS Then
            iSuccessCount = iSuccessCount + 1
        End If 'If lRtn = ERROR_SUCCESS
        lRtn = RegCloseKey(lHKey)      'close the Registry
    End If 'If lRtn = ERROR_SUCCESS
    End If 'If Trim$(sValue) <> ""
    If iSuccessCount > 0 Then
    RegWrite = True                    'OK, changed
    End If 'If iSuccessCount > 0
Exit_RegWrite:
  On Error Resume Next
  Exit Function
Err_RegWrite:
    Select Case Err.Number
    Case Else
        ErrorHandler Err.Number, Err.Description, "RegWrite_basReg"
    End Select
  Resume Exit_RegWrite
End Function

---

Since my projects that use the registry usually use the same location with different keys, I usually have a couple functions for quick read/write access and a constant for the registry location:

Code:

---

Public Const RegistryLoc = "Software\Microsoft\Office"
Private Function LoadValue(ByVal vKey As String) As String
LoadValue = RegRead(RegistryLoc, CStr(vKey), HKCU)
End Function

Private Function SetValue(ByVal vKey As String, ByVal vValue As String) As Boolean
RegWrite RegistryLoc, CStr(vKey), vValue, HKCU
End Function

---

Let me know if you have any questions! Looks confusing, really isn't (though isn't as need as the wscript way).
Matt

Thanks for the speedy replies!

Marcster
I've opted for a code solution given there may be occasions where I'm not in charge of the PC being used and won't have control over the version of windows script host. I saw that thread you linked to but I couldn't work out how it applied to my situation. I think I can see why this doesn't work now so thanks again.

Matt
I extracted what I thought were the pieces I needed but it doesn't seem to be returning any values in either Windows XP or 98. Can you see what I have done wrong?

Here's a sample of the code where I call the function :

Code:

---

Public Function GetProcessorInfo()
   
    Dim KeyPath As String
   
    KeyPath = _
    "HKEY_LOCAL_MACHINE\Hardware\Description\System\CentralProcessor\0\"

    GetProcessorInfo = Trim(RegRead(KeyPath, "VendorIdentifier"))

End Function

---

And here is the code that I inserted into a new module (it is a cut down version of your code) :

Code:

---

Option Explicit

Public Const ERROR_SUCCESS& = 0
Public Const HKEY_CURRENT_USER = &H80000001
Public Const REG_SZ                As Long = 1

Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_QUERY_VALUE = &H1&
Const READ_CONTROL = &H20000
Const STANDARD_RIGHTS_READ = READ_CONTROL

Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

Public Function RegRead(sKey As String, sValueName As String, Optional _
        vntOptionalHKey As Variant) As String
       
        Dim lOptionalHKey                        As Long
        Dim lKeyType                                As Long
        Dim lHKey                                        As Long 'return handle to opened key
        Dim lpcbData                                As Long 'length of data in returned string
        Dim sReturnedString                  As String 'returned string value
        Dim sTemp                                        As String 'temp string
        Dim lRtn                                        As Long 'success or not success
       
        On Error GoTo Err_RegRead
       
        If IsMissing(vntOptionalHKey) Then
                lOptionalHKey = HKEY_CURRENT_USER 'Use current user
        Else
                lOptionalHKey = vntOptionalHKey 'Use the one supplied
        End If 'If IsMissing(vntOptionalHKey)
        lKeyType = REG_SZ 'data type is string
        lRtn = RegOpenKeyEx(lOptionalHKey, sKey, 0&, KEY_READ, lHKey)
        If lRtn = ERROR_SUCCESS Then
                lpcbData = 1024 'get this many characters
                sReturnedString = Space$(lpcbData) 'setup the buffer
                lRtn = RegQueryValueEx(lHKey, sValueName, ByVal 0&, lKeyType, _
                sReturnedString, lpcbData)
                If lRtn = ERROR_SUCCESS Then
                        sTemp = Left$(sReturnedString, lpcbData - 1)
                End If 'If lRtn = ERROR_SUCCESS
                RegCloseKey lHKey
        End If 'If lRtn = ERROR_SUCCESS
        RegRead = sTemp
       
Exit_RegRead:
        On Error Resume Next
        RegCloseKey lHKey
        Exit Function
       
Err_RegRead:
        'Select Case Err.Number
        'Case Else
        '        ErrorHandler Err.Number, Err.Description, "RegRead_basReg"
        'End Select
        MsgBox "Cannot read registry value", vbCritical, "Error"
        Resume Exit_RegRead
End Function

---

Any pointers as to why this doesn't work would be appreciated.

TIA, Andrew

P.S. It appears to fail at this line : "lRtn = RegOpenKeyEx(lOptionalHKey, sKey, 0&, KEY_READ, lHKey)" because this returns a value of 2 but to read the key I need it to return a value of 0, so I suspect one of the pass through variables is not correct. Given I have supplied the full key path, but there is some "fiddling" going on with the HKCU (?), then I suspect the true error is with the lOptionalHKey field. Unfortunately I don't know enough about VB to correct this myself.

Hi Andrew,

You are close, and you have the correct reasoning. You can change your GetProcessorInfo function to

Code:

---

Public Function GetProcessorInfo()
    Dim KeyPath As String
    KeyPath = "Hardware\Description\System\CentralProcessor\0"
    GetProcessorInfo = Trim(RegRead(KeyPath, "VendorIdentifier", HKEY_LOCAL_MACHINE))
End Function

---

And make sure to add this to the Const section of your regread part:

Code:

---

Public Const HKEY_LOCAL_MACHINE = &H80000002

---

I'm sure you can see what the error is, you included the HKLM into the key path, when it should be a separate value.
Matt

Hi Matt

Thank you very much for your response. It is all so obvious once it is pointed out. I'm a novice with VB but am learning pretty quickly. Thanks again for your help. Your change works perfectly and I can now use this methodology elsewhere. My script runs on both the XP and Win98 platforms (I suppose I should now test some other platforms....)

Thanks again
Andrew
:thumb
:cloud9: