Reading, Writing, Registry

[SmashingPiggy]

Howdy all,

I am writing a VB program and I need to save program information from execution to execution, setup stuff like file locations, etc. I am in a Windows NT environment, that of course makes each user logon to NT independently. Many users may launch this program, but it will be on the same machine.

VB's GetSetting and SaveSetting procedures are useless in this environment because they save the data to the HKEY_Current_User. I need to save my settings in the HKEY_Local_Machine section.

Can anyone give me pointers on how to get started? Surely there is some preexisting code out there that I can copy that will let me do this.


Thanks for all your help

[oetje]

I think this (http://www.vbapi.com/ref/funcc.html#registry) will help you.

[amdimauro]

Our applications write to the Local Machine Root of the registry as well.
You need to use the Registry API calls to do this.
Here's some code

The constant definitions...

Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_SZ As Long = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD As Long = 4

Private Const READ_CONTROL = &H20000
Private Const SYNCHRONIZE = &H100000
Private Const KEY_ALL_ACCESS As Long = &H3F
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_READ = ((READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Enum RegistryRootConstants
HKEY_Classes_Root = &H80000000
HKEY_Current_User = &H80000001
HKEY_Local_Machine = &H80000002
HKEY_Users = &H80000003
HKEY_Performance_Data = &H80000004
HKEY_Current_Config = &H80000005
HKEY_Dyn_Data = &H80000006
End Enum



The API declarations...

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long

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

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

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

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




The SaveSetting and GetSetting routines utilizing the API calls..

Public Sub SaveSetting(ByVal szRegistrySection As String, ByVal szRegistryKey As String, ByVal szRegistrySetting As String)
Dim lReturnValue As Long
Dim hKey As Long

lReturnValue = RegCreateKeyEx(HKEY_Local_Machine, szRegistrySection, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lReturnValue)
lReturnValue = RegSetValueExString(hKey, szRegistryKey, 0&, REG_SZ, szRegistrySetting, Len(szRegistrySetting))
RegCloseKey hKey
End Sub


Public Function GetSetting(ByVal szRegistrySection As String, ByVal szRegistryKey As String, ByVal szDefaultRegistrySetting As String) As String
Dim szRegistrySetting As String
Dim lReturnValue As Long
Dim lData As Long
Dim hKey As Long

lReturnValue = RegOpenKeyEx(HKEY_Local_Machine, szRegistrySection, 0, KEY_READ, hKey)
lReturnValue = RegQueryValueExNULL(hKey, szRegistryKey, 0&, REG_SZ, 0&, lData)

szRegistrySetting = String(lData, 0)
lReturnValue = RegQueryValueExString(hKey, szRegistryKey, 0&, REG_SZ, szRegistrySetting, lData)
If lReturnValue = 0 Then
szRegistrySetting = Left(szRegistrySetting, lData - 1)
Else
szRegistrySetting = szDefaultRegistrySetting
End If

RegCloseKey hKey

GetSetting = szRegistrySetting
End Function




Sample on how to use these routines...these will write to the "HKEY_Local_Machine/Software" area of the registry.
Create a new project, to the form, add 2 text boxes and 2 command buttons.


Private Sub Command1_Click()
SaveSetting "SOFTWARE\SmashingPiggy", "Test", Text1.Text
End Sub


Private Sub Command2_Click()
Text2.Text = GetSetting("SOFTWARE\SmashingPiggy", "Test", "Default")
End Sub

[paulw]

Glad there wasn't TOO much code to run through - I'd have never understood it otherwise <grin>

P.

[oetje]

Andimauro, I think you need to change the names of the function.
Maybe vb will give an error, because it already uses the names 'savesetting' and 'getsetting'.

[SmashingPiggy]

amdimauro,

WOW! That is a lot to digest, but it looks really great. I will work through all of the code and make sure I understand it.

I am trying to build all of this into a code module, so that it goes in the standard code library for our department to use, so I have a few questions about your code:

1) Error Handling? How do you know that the save or get setting procedures worked.

2) How much danger is there if messing up the registry while I am learning to use these APIs?

3) Can I "assume" that the advapi32.dll is on all Windows workstations or does it have to be included in the setup package?


Thanks again 8o)

[amdimauro]

1. Sorry for not include Error Constants
All the Registry API calls will return 0 for SUCCESS, and a Non-Zero number for Failure.

Here's the list of Return Codes we use...

Private Const ERROR_NONE As Long = 0
Private Const ERROR_BADDB As Long = 1
Private Const ERROR_BADKEY As Long = 2
Private Const ERROR_CANTOPEN As Long = 3
Private Const ERROR_CANTREAD As Long = 4
Private Const ERROR_CANTWRITE As Long = 5
Private Const ERROR_OUTOFMEMORY As Long = 6
Private Const ERROR_INVALID_PARAMETER As Long = 7
Private Const ERROR_ACCESS_DENIED As Long = 8
Private Const ERROR_INVALID_PARAMETERS As Long = 87
Private Const ERROR_NO_MORE_ITEMS As Long = 259


2. Alot!!! But as long as you are writing to your own area in the registry, everything will be okay...
i.e. You should always test with the Registry Section such as "SOFTWARE/SmashingPiggy" as the beginning root...
You could also create more registry 'folders' under this by using "SOFTWARE/SmashingPiggy/Test", "SOFTWARE/SmashingPiggy/More Stuff", etal

3. I never assume...but "advapi32.dll" should be a standard Windows DLL.
Although, we do all our code development on and for WindowsNT/Windows2000. I would include it in a setup package.

[SmashingPiggy]

oetje,

That was a great link you left. There is a lot of great information there.

Thanks again.

[SmashingPiggy]

amdimauro,

thanks again for the error information. Between what you and oetje have provided me, I am well on the way to Reading and Writing Registry entries.

I will heed your advice and be very very careful during my testing. Fortunately, I would want all of my program's settings in a seperate section, so it will be easy to follow your directions.

I will make sure that advapi32.dll is included in the package, just in case it is needed.


Thanks again, this has been a big help. :)

Code for a Module.

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal HKEY As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal HKEY As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal HKEY As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal HKEY As Long, ByVal lpValueName As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal HKEY As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal HKEY As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" 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
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const REG_SZ = 1

Function RegQueryStringValue(ByVal HKEY As Long, ByVal strValueName As String)
Dim lResult As Long
Dim lValueType As Long
Dim strBuf As String
Dim lDataBufSize As Long

On Error GoTo 0
lResult = RegQueryValueEx(HKEY, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(HKEY, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
RegQueryStringValue = StripTerminator(strBuf)
End If
End If
End If
End Function

Public Function GetSettingEx(HKEY As Long, sPath As String, sValue As String)
Dim KeyHand&
Dim datatype&
Call RegOpenKey(HKEY, sPath, KeyHand&)
GetSettingEx = RegQueryStringValue(KeyHand&, sValue)
Call RegCloseKey(KeyHand&)
End Function

Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer

intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End If
End Function

Public Sub SaveSettingEx(HKEY As Long, sPath As String, sValue As String, sData As String)
Dim KeyHand As Long
Call RegCreateKey(HKEY, sPath, KeyHand)
Call RegSetValueEx(KeyHand&, sValue, 0, REG_SZ, ByVal sData, Len(sData))
Call RegCloseKey(KeyHand&)
End Sub


Usage:

'Save a Value to the Registry
SaveSettingEx HKEY_CURRENT_USER, "Software\Myapp", "Testing", "Hello"


'Get a value from the Registry
Retval = GetSettingEx(HKEY_CURRENT_USER, "Software\Myapp", "Testing")
Print Retval

[jsun9]

i love you megatron. (translated-you really helped me out a lot.)

[henry770]

The dad gum forum won't let me post this whole class at once, so I will do it piece by piece until I get it all.

[henry770]

Option Explicit

'Registry Specific Access Rights
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_ALL_ACCESS = &H3F

'Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

'Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2

'masks for the predefined standard access types
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF

'Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 ' dderror
Private Const ERROR_NO_MORE_ITEMS = 259


'Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

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

Private Declare Function RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long

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

Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey 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 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 FILETIME) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) 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, ByVal lpType As Long, _
ByVal lpData As Long, ByVal lpcbData As Long) As Long

Private Declare Function RegEnumValueLong 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 Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr 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, _
ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte 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 Byte, lpcbData As Long) As Long

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
(ByVal hKey As Long, ByVal lpClass As String, _
lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, _
lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
lpftLastWriteTime As Any) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long

' Other declares:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long


Public Enum ERegistryClassConstants
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum

Public Enum ERegistryValueTypes
'Predefined Value Types
REG_NONE = (0) 'No value type
REG_SZ = (1) 'Unicode nul terminated string
REG_EXPAND_SZ = (2) 'Unicode nul terminated string w/enviornment var
REG_BINARY = (3) 'Free form binary
REG_DWORD = (4) '32-bit number
REG_DWORD_LITTLE_ENDIAN = (4) '32-bit number (same as REG_DWORD)
REG_DWORD_BIG_ENDIAN = (5) '32-bit number
REG_LINK = (6) 'Symbolic Link (unicode)
REG_MULTI_SZ = (7) 'Multiple Unicode strings
REG_RESOURCE_LIST = (8) 'Resource list in the resource map
REG_FULL_RESOURCE_DESCRIPTOR = (9) 'Resource list in the hardware description
REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum

Private m_hClassKey As Long
Private m_sSectionKey As String
Private m_sValueKey As String
Private m_vValue As Variant
Private m_sSetValue As String
Private m_vDefault As Variant
Private m_eValueType As ERegistryValueTypes

[henry770]

Public Property Get KeyExists() As Boolean
'KeyExists = bCheckKeyExists( _
' m_hClassKey, _
' m_sSectionKey _
' )
Dim hKey As Long
If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, hKey) = ERROR_SUCCESS Then
KeyExists = True
RegCloseKey hKey
Else
KeyExists = False
End If

End Property
Public Function CreateKey() As Boolean
Dim tSA As SECURITY_ATTRIBUTES
Dim hKey As Long
Dim lCreate As Long
Dim e As Long

'Open or Create the key
e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, tSA, hKey, lCreate)
If e Then
Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to create registry Key: '" & m_sSectionKey
Else
CreateKey = (e = ERROR_SUCCESS)
'Close the key
RegCloseKey hKey
End If
End Function
Public Function DeleteKey() As Boolean
Dim e As Long
e = RegDeleteKey(m_hClassKey, m_sSectionKey)
If e Then
'Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey
Else
DeleteKey = (e = ERROR_SUCCESS)
End If

End Function
Public Function DeleteValue() As Boolean
Dim e As Long
Dim hKey As Long

e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, hKey)
If e Then
Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key '" & m_hClassKey & "',Section: '" & m_sSectionKey & "' for delete access"
Else
e = RegDeleteValue(hKey, m_sValueKey)
If e Then
Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey
Else
DeleteValue = (e = ERROR_SUCCESS)
End If
End If

End Function
Public Property Get Value() As Variant
Dim vValue As Variant
Dim cData As Long, sData As String, ordType As Long, e As Long
Dim hKey As Long

e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
'ApiRaiseIf*e

e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, 0&, cData)
If e And e <> ERROR_MORE_DATA Then
Value = m_vDefault
Exit Property
End If

m_eValueType = ordType
Select Case ordType
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
Dim iData As Long
e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
ordType, iData, cData)
vValue = CLng(iData)

Case REG_DWORD_BIG_ENDIAN ' Unlikely, but you never know
Dim dwData As Long
e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
ordType, dwData, cData)
vValue = SwapEndian(dwData)

Case REG_SZ, REG_MULTI_SZ ' Same thing to Visual Basic
sData = String$(cData - 1, 0)
e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
ordType, sData, cData)
vValue = sData

Case REG_EXPAND_SZ
sData = String$(cData - 1, 0)
e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
ordType, sData, cData)
vValue = ExpandEnvStr(sData)

' Catch REG_BINARY and anything else
Case Else
Dim abData() As Byte
ReDim abData(cData)
e = RegQueryValueExByte(hKey, m_sValueKey, 0&, _
ordType, abData(0), cData)
vValue = abData

End Select
Value = vValue

End Property
Public Property Let Value( _
ByVal vValue As Variant _
)
Dim ordType As Long
Dim c As Long
Dim hKey As Long
Dim e As Long
Dim lCreate As Long
Dim tSA As SECURITY_ATTRIBUTES

'Open or Create the key
e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, tSA, hKey, lCreate)

If e Then
Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
Else

Select Case m_eValueType
Case REG_BINARY
If (VarType(vValue) = vbArray + vbByte) Then
Dim ab() As Byte
ab = vValue
ordType = REG_BINARY
c = UBound(ab) - LBound(ab) - 1
e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
Else
Err.Raise 26001
End If
Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
Dim i As Long
i = vValue
ordType = REG_DWORD
e = RegSetValueExLong(hKey, m_sValueKey, 0&, ordType, i, 4)
End If
Case REG_SZ, REG_EXPAND_SZ
Dim s As String, iPos As Long
s = vValue
ordType = REG_SZ
' Assume anything with two non-adjacent percents is expanded string
iPos = InStr(s, "%")
If iPos Then
If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
End If
c = Len(s) + 1
e = RegSetValueExStr(hKey, m_sValueKey, 0&, ordType, s, c)

' User should convert to a compatible type before calling
Case Else
e = ERROR_INVALID_DATA

End Select

If Not e Then
m_vValue = vValue
Else
Err.Raise vbObjectError + 1048 + 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
End If

'Close the key
RegCloseKey hKey

End If

End Property
Public Function EnumerateValues( _
ByRef sKeyNames() As String, _
ByRef iKeyCount As Long _
) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim sName As String
Dim lNameSize As Long
Dim sData As String
Dim lIndex As Long
Dim cJunk As Long
Dim cNameMax As Long
Dim ft As Currency

' Log "EnterEnumerateValues"

iKeyCount = 0
Erase sKeyNames()

lIndex = 0
lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
If (lResult = ERROR_SUCCESS) Then
' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
lResult = RegQueryInfoKey(hKey, "", cJunk, 0, _
cJunk, cJunk, cJunk, cJunk, _
cNameMax, cJunk, cJunk, ft)
Do While lResult = ERROR_SUCCESS

'Set buffer space
lNameSize = cNameMax + 1
sName = String$(lNameSize, 0)
If (lNameSize = 0) Then lNameSize = 1

' Log "Requesting Next Value"

'Get value name:
lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, _
0&, 0&, 0&, 0&)
' Log "RegEnumValue returned:" & lResult
If (lResult = ERROR_SUCCESS) Then

' Although in theory you can also retrieve the actual
' value and type here, I found it always (ultimately) resulted in
' a GPF, on Win95 and NT. Why? Can anyone help?

sName = Left$(sName, lNameSize)
' Log "Enumerated value:" & sName

iKeyCount = iKeyCount + 1
ReDim Preserve sKeyNames(1 To iKeyCount) As String
sKeyNames(iKeyCount) = sName
End If
lIndex = lIndex + 1
Loop
End If
If (hKey <> 0) Then
RegCloseKey hKey
End If

' Log "Exit Enumerate Values"
EnumerateValues = True
Exit Function

EnumerateValuesError:
If (hKey <> 0) Then
RegCloseKey hKey
End If
Err.Raise vbObjectError + 1048 + 26003, App.EXEName & ".cRegistry", Err.Description
Exit Function

End Function

[henry770]

Public Function EnumerateSections( _
ByRef sSect() As String, _
ByRef iSectCount As Long _
) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim dwReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
Dim iPos As Long

On Error GoTo EnumerateSectionsError

iSectCount = 0
Erase sSect
'
lIndex = 0

lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
Do While lResult = ERROR_SUCCESS
'Set buffer space
szBuffer = String$(255, 0)
lBuffSize = Len(szBuffer)

'Get next value
lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)

If (lResult = ERROR_SUCCESS) Then
iSectCount = iSectCount + 1
ReDim Preserve sSect(1 To iSectCount) As String
iPos = InStr(szBuffer, Chr$(0))
If (iPos > 0) Then
sSect(iSectCount) = Left(szBuffer, iPos - 1)
Else
sSect(iSectCount) = Left(szBuffer, lBuffSize)
End If
End If

lIndex = lIndex + 1
Loop
If (hKey <> 0) Then
RegCloseKey hKey
End If
EnumerateSections = True
Exit Function

EnumerateSectionsError:
If (hKey <> 0) Then
RegCloseKey hKey
End If
Err.Raise vbObjectError + 1048 + 26002, App.EXEName & ".cRegistry", Err.Description
Exit Function
End Function
Private Sub pSetClassValue(ByVal sValue As String)
Dim sSection As String
ClassKey = HKEY_CLASSES_ROOT
Value = sValue
sSection = SectionKey
ClassKey = HKEY_LOCAL_MACHINE
SectionKey = "SOFTWARE\Classes\" & sSection
Value = sValue
SectionKey = sSection
End Sub
Public Sub CreateEXEAssociation( _
ByVal sExePath As String, _
ByVal sClassName As String, _
ByVal sClassDescription As String, _
ByVal sAssociation As String, _
Optional ByVal sOpenMenuText As String = "&Open", _
Optional ByVal bSupportPrint As Boolean = False, _
Optional ByVal sPrintMenuText As String = "&Print", _
Optional ByVal bSupportNew As Boolean = False, _
Optional ByVal sNewMenuText As String = "&New", _
Optional ByVal bSupportInstall As Boolean = False, _
Optional ByVal sInstallMenuText As String = "", _
Optional ByVal lDefaultIconIndex As Long = -1 _
)
' Check if path is wrapped in quotes:
sExePath = Trim$(sExePath)
If (Left$(sExePath, 1) <> """") Then
sExePath = """" & sExePath
End If
If (Right$(sExePath, 1) <> """") Then
sExePath = sExePath & """"
End If

' Create the .File to Class association:
SectionKey = "." & sAssociation
ValueType = REG_SZ
ValueKey = ""
pSetClassValue sClassName

' Create the Class shell open command:
SectionKey = sClassName
pSetClassValue sClassDescription

SectionKey = sClassName & "\shell\open"
If (sOpenMenuText = "") Then sOpenMenuText = "&Open"
ValueKey = ""
pSetClassValue sOpenMenuText
SectionKey = sClassName & "\shell\open\command"
ValueKey = ""
pSetClassValue sExePath & " ""%1"""

If (bSupportPrint) Then
SectionKey = sClassName & "\shell\print"
If (sPrintMenuText = "") Then sPrintMenuText = "&Print"
ValueKey = ""
pSetClassValue sPrintMenuText
SectionKey = sClassName & "\shell\print\command"
ValueKey = ""
pSetClassValue sExePath & " /p ""%1"""
End If

If (bSupportInstall) Then
If (sInstallMenuText = "") Then
sInstallMenuText = "&Install " & sAssociation
End If
SectionKey = sClassName & "\shell\add"
ValueKey = ""
pSetClassValue sInstallMenuText
SectionKey = sClassName & "\shell\add\command"
ValueKey = ""
pSetClassValue sExePath & " /a ""%1"""
End If

If (bSupportNew) Then
SectionKey = sClassName & "\shell\new"
ValueKey = ""
If (sNewMenuText = "") Then sNewMenuText = "&New"
pSetClassValue sNewMenuText
SectionKey = sClassName & "\shell\new\command"
ValueKey = ""
pSetClassValue sExePath & " /n ""%1"""
End If

If lDefaultIconIndex > -1 Then
SectionKey = sClassName & "\DefaultIcon"
ValueKey = ""
pSetClassValue sExePath & "," & CStr(lDefaultIconIndex)
End If

End Sub
Public Sub CreateAdditionalEXEAssociations( _
ByVal sClassName As String, _
ParamArray vItems() As Variant _
)
Dim iItems As Long
Dim iItem As Long

On Error Resume Next
iItems = UBound(vItems) + 1
If (iItems Mod 3) <> 0 Or (Err.Number <> 0) Then
Err.Raise vbObjectError + 1048 + 26004, App.EXEName & ".cRegistry", "Invalid parameter list passed to CreateAdditionalEXEAssociations - expected Name/Text/Command"
Else
' Check if it exists:
SectionKey = sClassName
If Not (KeyExists) Then
Err.Raise vbObjectError + 1048 + 26005, App.EXEName & ".cRegistry", "Error - attempt to create additional associations before class defined."
Else
For iItem = 0 To iItems - 1 Step 3
ValueType = REG_SZ
SectionKey = sClassName & "\shell\" & vItems(iItem)
ValueKey = ""
pSetClassValue vItems(iItem + 1)
SectionKey = sClassName & "\shell\" & vItems(iItem) & "\command"
ValueKey = ""
pSetClassValue vItems(iItem + 2)
Next iItem
End If
End If

End Sub
Public Property Get ValueType() As ERegistryValueTypes
ValueType = m_eValueType
End Property
Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
m_eValueType = eValueType
End Property
Public Property Get ClassKey() As ERegistryClassConstants
ClassKey = m_hClassKey
End Property
Public Property Let ClassKey( _
ByVal eKey As ERegistryClassConstants _
)
m_hClassKey = eKey
End Property
Public Property Get SectionKey() As String
SectionKey = m_sSectionKey
End Property
Public Property Let SectionKey( _
ByVal sSectionKey As String _
)
m_sSectionKey = sSectionKey
End Property
Public Property Get ValueKey() As String
ValueKey = m_sValueKey
End Property
Public Property Let ValueKey( _
ByVal sValueKey As String _
)
m_sValueKey = sValueKey
End Property
Public Property Get Default() As Variant
Default = m_vDefault
End Property
Public Property Let Default( _
ByVal vDefault As Variant _
)
m_vDefault = vDefault
End Property
Private Function SwapEndian(ByVal dw As Long) As Long
CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
Private Function ExpandEnvStr(sData As String) As String
Dim c As Long, s As String
' Get the length
s = "" ' Needed to get around Windows 95 limitation
c = ExpandEnvironmentStrings(sData, s, c)
' Expand the string
s = String$(c - 1, 0)
c = ExpandEnvironmentStrings(sData, s, c)
ExpandEnvStr = s
End Function

[henry770]

Well, thats the last of it. Hopefully you guys will like it

[parksie]

Couldn't you just have attached it? :eek: Or at least put it in code tags ;) Looks good though :D