PDA

View Full Version : [SOLVED] Get Windows 98 registry values, VB6



andrew93
12-30-2005, 03:34 AM
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 :


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".

Marcster
12-30-2005, 04:41 AM
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/details.aspx?FamilyID=0a8a18f6-249c-4a72-bfcf-fc6af26dc390&DisplayLang=en

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

HTH,

Marcster.

mvidas
12-30-2005, 08:37 AM
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:


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:

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

andrew93
12-30-2005, 02:41 PM
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 :

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) :

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.

mvidas
01-03-2006, 10:08 AM
Hi Andrew,

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

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:


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

andrew93
01-03-2006, 03:59 PM
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: