Solved

Need help using RegEnumValue

Posted on 1998-11-03
4
438 Views
Last Modified: 2008-02-26
I'm unable to use the RegEnumValue it's always return me a 243 exit code anybody can give me a example or any trick?
0
Comment
Question by:powlin
4 Comments
 
LVL 14

Accepted Solution

by:
waty earned 20 total points
ID: 1443035
Here is a class you could use, it works perfectly.

' #VBIDEUtils#************************************************************
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 25/09/98
' * Time             : 14:49
' * Module Name      : class_Registry
' * Module Filename  : Registry.cls
' **********************************************************************
' * Comments         : This class is an easy, self-contained way to get
' *  complete access to the Windows registry.
' *  Simple methods allow you to create, enumerate and delete keys
' *  and values in the registry, without restriction.
' *  You can even read/write binary data to the registry.
' *
' * Example :
' *  get a String Value from the Registry
' *    Dim clsRegistry As New class_Registry
' *    With clsRegistry
' *       .ClassKey = HKEY_LOCAL_MACHINE
' *       .SectionKey = "Software\PrintPreview"
' *       .ValueKey = "Version"
' *       .ValueType = REG_SZ
' *       sTip = .Value
' *    End With
' *
' *  Save a Form's position to the Registry
' *    Dim clsRegistry As New class_Registry
' *    With clsRegistry
' *       .ClassKey = HKEY_CURRENT_USER
' *       ' You don't need to check if this key already exists
' *       ' - the class will create it for you
' *       .SectionKey = "Software\" & App.EXEName & "\" & frmThis.name
' *       .ValueKey = "Maximized"
' *       .ValueType = REG_DWORD
' *       .Value = (frmThis.WindowState = vbMaximized)
' *       If (frmThis.WindowState <> vbMaximized)
' *           .ValueKey = "Left"
' *           .Value = frmThis.Left
' *           .ValueKey = "Top"
' *           .Value = frmThis.Top
' *           .ValueKey = "Width"
' *           .Value = frmThis.Width
' *           .ValueKey = "Height"
' *           .Value = frmThis.Height
' *       End If
' *    End With
' *

' **********************************************************************

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
   HKEY_PERFORMANCE_DATA = &H80000004
   HKEY_CURRENT_CONFIG = &H80000005
   HKEY_DYN_DATA = &H80000006
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

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
   Dim sData      As String
   Dim ordType    As Long
   Dim 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

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

Public Sub CreateEXEAssociation(ByVal sExePath As String, ByVal sClassName As String, ByVal sClassDescription As String, ByVal sAssociation As String, Optional ByVal lDefaultIconIndex As Long = -1)
   
   ClassKey = HKEY_CLASSES_ROOT
   SectionKey = "." & sAssociation
   ValueKey = ""
   Value = sClassName
   SectionKey = "." & sAssociation & "\shell\open\command"
   ValueKey = ""
   Value = sExePath & " ""%1"""

   SectionKey = sClassName
   ValueKey = ""
   Value = sClassDescription
   SectionKey = sClassName & "\shell\open\command"
   ValueKey = sExePath & " ""%1"""
   If lDefaultIconIndex > -1 Then
      SectionKey = sClassName & "\DefaultIcon"
      ValueKey = ""
      Value = sExePath & "," & CStr(lDefaultIconIndex)
   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

Public Function GetRegistrySetting(nKeyRoot As ERegistryClassConstants, sKeyName As String, sSubKeyRef As String, sDefault As String, Optional vValueType As ERegistryValueTypes = REG_EXPAND_SZ) As String
   ' ***  *** Return the value of a settings in the registry

   ClassKey = nKeyRoot
   SectionKey = sKeyName
   ValueKey = sSubKeyRef
   Default = sDefault
   ValueType = vValueType

   GetRegistrySetting = Value

End Function

Public Sub SetRegistrySetting(nKeyRoot As ERegistryClassConstants, sSubKeyRef As String, sKeyName As String, sValue As String, Optional vValueType As ERegistryValueTypes = REG_EXPAND_SZ)
   ' ***  *** Set a value in the registry

   ClassKey = nKeyRoot
   SectionKey = sSubKeyRef
   ValueKey = sKeyName
   ValueType = vValueType
   Value = sValue

End Sub

0
 
LVL 13

Expert Comment

by:Mirkwood
ID: 1443036
Option Explicit

   Public Const REG_SZ As Long = 1
   Public Const REG_DWORD As Long = 4
   Public Const REG_EXPAND_SZ = 2
   Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
   Type FILETIME
           dwLowDateTime As Long
           dwHighDateTime As Long
   End Type

   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 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_INVALID_PARAMETER = 7
   Public Const ERROR_ACCESS_DENIED = 8
   Public Const ERROR_INVALID_PARAMETERS = 87
   Public Const ERROR_NO_MORE_ITEMS = 259

   Public Const KEY_ALL_ACCESS = &H3F

   Public Const REG_OPTION_NON_VOLATILE = 0

   Declare Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long
   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
   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
   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
   Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, lpData As _
   Long, lpcbData As Long) As Long
   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
   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
   Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
   ByVal cbData As Long) As Long
   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
   Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
      ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
      lpcbName As Long, lpReserved As Long, ByVal lpClass As String, _
      lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
   Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
      ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
      lpcbValueName As Long, lpReserved As Long, lpType As Long, _
      lpData As Byte, lpcbData As Long) As Long
   Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" ( _
      ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, 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 FILETIME) As Long
     


'***********************************
'********* SetValueEx
'***********************************
Public Function SetValueEx(ByVal hKey As Long, sValueName As String, _
   ltype As Long, vValue As Variant) As Long
       Dim lValue As Long
       Dim sValue As String
       Select Case ltype
           Case REG_SZ
               sValue = vValue + Chr$(0)
               SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                                              ltype, sValue, Len(sValue))
           Case REG_DWORD
               lValue = vValue
               Debug.Assert Len(sValueName) > 0 ' That does not work on windows 95
               SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, ltype, lValue, 4)
            Case Else
               Debug.Assert 0
           End Select
   End Function

'***********************************
'********* QueryValueEx
'***********************************
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
   String, vValue As Variant) As Long
       Dim cch As Long
       Dim lrc As Long
       Dim ltype As Long
       Dim lValue As Long
       Dim sValue As String

       On Error GoTo QueryValueExError

       ' Determine the size and type of data to be read
       lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, ltype, 0&, cch)
       If lrc  ERROR_NONE Then Error 5

       Select Case ltype
           ' For strings
           Case REG_SZ:
               sValue = String$(cch, 0)
               lrc = RegQueryValueExString(lhKey, szValueName, 0&, ltype, _
                                             sValue, cch)
               If lrc = ERROR_NONE Then
                    If (cch > 1) Then
                        vValue = Left$(sValue, cch - 1)
                    Else
                        vValue = ""
                    End If
               Else
                   vValue = Empty
               End If
           ' For DWORDS
           Case REG_DWORD:
               lrc = RegQueryValueExLong(lhKey, szValueName, 0&, ltype, _
                                          lValue, cch)
               If lrc = ERROR_NONE Then vValue = lValue
           Case REG_EXPAND_SZ:
               sValue = String$(cch, 0)
               lrc = RegQueryValueExString(lhKey, szValueName, 0&, ltype, _
                                             sValue, cch)
               If lrc = ERROR_NONE Then
                   Dim result As String
                   result = String$(2048, 0)
                   Dim size As Integer
                   size = ExpandEnvironmentStrings(Left$(sValue, cch - 1), result, 2048)
                   sValue = Left(result, size)
                   vValue = sValue
               Else
                   vValue = Empty
               End If
           Case Else
               'all other data types not supported
               lrc = -1
       End Select

QueryValueExExit:
       QueryValueEx = lrc
       Exit Function
QueryValueExError:
       Resume QueryValueExExit
   End Function

'***********************************
'********* EnumKey
'***********************************
Public Function EnumKey(ByVal hKey As Long, ByVal index As Long, ByRef key As String) As Long
   Dim cch As Long
   Dim lrc As Long
   Dim ltype As Long
   Dim lValue As Long
   Dim szKeyName As String
   
   cch = 260
   szKeyName = String$(cch, 0)
   lrc = RegEnumKey(hKey, index, szKeyName, cch)
   
   If (lrc = 0) Then
      key = Left$(szKeyName, InStr(szKeyName, Chr$(0)) - 1)
   End If
   
   EnumKey = lrc
End Function


'***********************************
'********* EnumValue
'***********************************
Public Function EnumValue(ByVal hKey As Long, ByVal index As Long, ByRef valueName As String) As Long
   Dim cch As Long
   Dim lrc As Long
   Dim ltype As Long
   Dim lValue As Long
   Dim szValueName As String
   
   'Not tested yet
   Debug.Assert 0
   
   cch = 260
   szValueName = String$(cch, 0)
   lrc = RegEnumValue(hKey, index, szValueName, cch, 0, 0, 0, 0)
   
   If (lrc = 0) Then
      valueName = Left$(szValueName, InStr(szValueName, Chr$(0)) - 1)
   End If
   
   EnumValue = lrc
End Function


'***********************************
'********* SetXXXValue
'***********************************
Public Sub SetXXXValue(ByVal RootKey As Long, ByVal sKeyName As String, ByVal sValueName As String, ByVal ltype As Long, ByVal value As Variant)
    Dim lRetval As Long         'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim lDispo As Long

    lRetval = RegOpenKeyEx(RootKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    If (lRetval  0) Then
       lRetval = RegCreateKeyEx(RootKey, sKeyName, 0, "", 0, KEY_ALL_ACCESS, 0, hKey, lDispo)
    End If
    If (lRetval = 0) Then
        lRetval = SetValueEx(hKey, sValueName, ltype, value)
        RegCloseKey (hKey)
    End If
End Sub

Public Sub SetUserValue(ByVal sKeyName As String, ByVal sValueName As String, ByVal ltype As Long, ByVal value As Variant)
   SetXXXValue HKEY_CURRENT_USER, sKeyName, sValueName, ltype, value
End Sub

Public Sub SetMachineValue(ByVal sKeyName As String, ByVal sValueName As String, ByVal ltype As Long, ByVal value As Variant)
   SetXXXValue HKEY_LOCAL_MACHINE, sKeyName, sValueName, ltype, value
End Sub

Public Sub SetClassesValue(ByVal sKeyName As String, ByVal sValueName As String, ByVal ltype As Long, ByVal value As Variant)
   SetXXXValue HKEY_CLASSES_ROOT, sKeyName, sValueName, ltype, value
End Sub

'***********************************
'********* QueryXXXValue
'***********************************

Public Function QueryXXXValue(ByVal RootKey As Long, ByVal sKeyName As String, ByVal sValueName As String) As Variant
    Dim lRetval As Long         'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim vValue As Variant      'setting of queried value

    lRetval = RegOpenKeyEx(RootKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    If (lRetval = 0) Then
      lRetval = QueryValueEx(hKey, sValueName, vValue)
       If Not (lRetval = 0) Then
         vValue = Empty
       End If
        RegCloseKey (hKey)
    End If
   
    QueryXXXValue = vValue
End Function

Public Function QueryUserValue(ByVal sKeyName As String, ByVal sValueName As String) As Variant
   QueryUserValue = QueryXXXValue(HKEY_CURRENT_USER, sKeyName, sValueName)
End Function

Public Function QueryMachineValue(ByVal sKeyName As String, ByVal sValueName As String) As Variant
   QueryMachineValue = QueryXXXValue(HKEY_LOCAL_MACHINE, sKeyName, sValueName)
End Function

Public Function QueryClassesValue(ByVal sKeyName As String, ByVal sValueName As String) As Variant
   QueryClassesValue = QueryXXXValue(HKEY_CLASSES_ROOT, sKeyName, sValueName)
End Function

'***********************************
'********* EnumXXXValues
'***********************************
Public Function EnumXXXValues(ByVal RootKey As Long, ByVal sKeyName As String) As Variant
   Dim i As Long
   Dim nrValues As Long
   Dim lrc As Long
   Dim value As String
   Dim hKey As Long
   Dim AllValuesCollection As New Collection
   Dim lRetval As Long
   Dim vValues() As String
   
   
   On Error GoTo leave
   hKey = 0
   lRetval = RegOpenKeyEx(RootKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
   If (lRetval = 0) Then
      lrc = 0
      i = 0
      'Request all Values
      While lrc = 0
         lrc = EnumValue(hKey, i, value)
         If (lrc = 0) Then
            i = i + 1
            AllValuesCollection.Add value, "Value" & i
         End If
      Wend
     
      'Copy all Values in a variant array
      If (i > 0) Then
         nrValues = i
         ReDim vValues(nrValues - 1) As String
         For i = 1 To nrValues
            vValues(i - 1) = AllValuesCollection("Value" & i)
         Next
      End If
   End If
   
   'Set return value
   EnumXXXValues = vValues
leave:
    If (hKey  0) Then
        RegCloseKey hKey
    End If
End Function

Public Function EnumUserValues(ByVal sKeyName As String) As Variant
   EnumUserValues = EnumXXXValues(HKEY_CURRENT_USER, sKeyName)
End Function

Public Function EnumMachineValues(ByVal sKeyName As String) As Variant
   EnumMachineValues = EnumXXXValues(HKEY_LOCAL_MACHINE, sKeyName)
End Function

Public Function EnumClassesValues(ByVal sKeyName As String) As Variant
   EnumClassesValues = EnumXXXValues(HKEY_CLASSES_ROOT, sKeyName)
End Function

'***********************************
'********* EnumXXXKeys
'***********************************
Public Function EnumXXXKeys(ByVal RootKey As Long, ByVal sKeyName As String) As Variant
   Dim i As Long
   Dim nrKeys As Long
   Dim lrc As Long
   Dim key As String
   Dim hKey As Long
   Dim AllKeysCollection As New Collection
   Dim vKeys() As String
   Dim lRetval As Long
   
   
   
   On Error GoTo leave
   hKey = 0
   lRetval = RegOpenKeyEx(RootKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
   If (lRetval = 0) Then
      lrc = 0
      i = 0
      'Request all keys
      While lrc = 0
         lrc = EnumKey(hKey, i, key)
         If (lrc = 0) Then
            i = i + 1
            AllKeysCollection.Add key, "Key" & i
         End If
      Wend
     
      'Copy all keys in a variant array
      If (i > 0) Then
         nrKeys = i
         ReDim vKeys(nrKeys - 1) As String
         For i = 1 To nrKeys
            vKeys(i - 1) = AllKeysCollection("Key" & i)
         Next
      End If
   End If
   
   'Set return value
   EnumXXXKeys = vKeys
leave:
    If (hKey  0) Then
        RegCloseKey hKey
    End If
End Function

Public Function EnumUserKeys(ByVal sKeyName As String) As Variant
   EnumUserKeys = EnumXXXKeys(HKEY_CURRENT_USER, sKeyName)
End Function

Public Function EnumMachineKeys(ByVal sKeyName As String) As Variant
   EnumMachineKeys = EnumXXXKeys(HKEY_LOCAL_MACHINE, sKeyName)
End Function

Public Function EnumClassesKeys(ByVal sKeyName As String) As Variant
   EnumClassesKeys = EnumXXXKeys(HKEY_CLASSES_ROOT, sKeyName)
End Function

Public Function RegClassesHasSubKeys(ByVal sKeyName As String) As Boolean
   Dim lRetval As Long
   Dim subkeys As Long
   Dim hKey As Long         'handle of opened key
   Dim ft As FILETIME
   Dim Class As String
   Dim cbClass As Long
   Dim cbMaxSubKeyLen As Long
   Dim cbMaxClassLen As Long
   Dim cValues As Long
   Dim cbMaxValueNameLen As Long
   Dim cbMaxValueLen As Long
   Dim cbSecurityDescriptor As Long
   
   RegClassesHasSubKeys = False
   lRetval = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_ALL_ACCESS, hKey)
   If (lRetval = 0) Then
      lRetval = RegQueryInfoKey(hKey, Class, cbClass, ByVal 0, subkeys, cbMaxSubKeyLen, cbMaxClassLen, _
                                cValues, cbMaxValueNameLen, cbMaxValueLen, cbSecurityDescriptor, ft)
      If (lRetval = 0) And subkeys > 0 Then
         RegClassesHasSubKeys = True
      Else
         RegClassesHasSubKeys = False
      End If
       RegCloseKey hKey
   End If
End Function

0
 
LVL 1

Author Comment

by:powlin
ID: 1443037
this answer work perfectly but a little bit long i only keep 10 line hehehehe thank
0
 

Expert Comment

by:dazzie
ID: 3886214
For me the most important points from waty's answer (which is great by the way) were:

1. Managing the name buffer for the results:

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

2. My code wouldn't work until I changed the declaration for RegEnumValue from (copied from Visual Studio 6.0 Win32api.txt file):

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 Byte, lpcbData As Long) As Long


to (copied from the above answer):

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

Note the byVals in the last 3 parameter declarations. This made all the difference.  Maybe someone could explain why.

0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now