?
Solved

write dword to the registry

Posted on 2005-03-09
10
Medium Priority
?
823 Views
Last Modified: 2008-01-09
Hi

I need to write a DWORD value to the registry.
I need to write the following
"HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableChangePassword" =  1 as long

I will then need to change the value to 0

The only other thing is I know that
"HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\" exists already but the rest would need to be created if it doesn't already exist

i'm sure this is a nice easy one for someone out there!

0
Comment
Question by:jclothier
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
  • 2
  • +1
10 Comments
 
LVL 53

Accepted Solution

by:
Dhaest earned 2000 total points
ID: 13494796
If you include a reference to Windows Scripting in your project, you can write to the registry with just a couple of lines of code.

dim wshShell
Set wshShell = CreateObject("WScript.Shell")
strTemp = WshShell.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\")

WshShell.RegWrite ("HKCU\\Software\\ACME\\FortuneTeller\\MindReader", "Goocher!", "REG_SZ");

Full docs are at http://msdn.microsoft.com/library/default.asp?url=/library/en-us/script56/html/wsmthregwrite.asp
0
 
LVL 53

Expert Comment

by:Dhaest
ID: 13494799
Without API's

'Read a registry key

Sub Main()
Dim RegObj, RegKey
Set RegObj = CreateObject("WScript.Shell")
RegKey = RegObj.RegRead("REGISTRY_KEY_TO_READ")
If RegKey = "" Then MsgBox "There is no registry value for this key!"
Else
MsgBox "Registry key value is " & RegKey & "!"
Set RegObj = Nothing
End If
End Sub

'Write a registry key

Sub Main()
Dim RegObj, RegKey As String
Set RegObj = CreateObject("WScript.Shell")
RegKey = "REGISTRY_KEY_TO_WRITE"
RegObj.RegWrite RegKey, "Value for the key goes here!"
Set RegObj = Nothing
End Sub

'Delete a registry key

Sub Main()
Dim RegObj
Set RegObj = CreateObject("WScript.Shell")
RegObj.RegDelete("REGISTRY_KEY_TO_DELETE")
Set RegObj = Nothing
End Sub
0
 
LVL 53

Expert Comment

by:Dhaest
ID: 13494800
HOWTO: Use the Registry API to Save and Retrieve Setting
http://support.microsoft.com/default.aspx?scid=kb;en-us;145679
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
LVL 76

Expert Comment

by:David Lee
ID: 13494827
Hi jclothier,

This should do it.

    Set wshShell = CreateObject("Wscript.Shell")
    wshShell.RegWrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableChangePassword", 0, "REG_DWORD"


Cheers!
0
 

Author Comment

by:jclothier
ID: 13494829
Thanks Dhaest

I knew it would be easy. Just couldn't seem to get my head into gear today!
0
 
LVL 76

Expert Comment

by:David Lee
ID: 13494830
I really need to learn to refresh first.
0
 
LVL 12

Expert Comment

by:gbzhhu
ID: 13494844
If you don't mind using API here is a whole project.  Just extract what you need

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_KEY_NOT_FOUND = 2
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const ERROR_INVALID_PARAMETER = 87
Private Const VALUE_ERROR = "Error!  No value found"

'Miscellaneous constants
Private Const MAX_PATH = 260

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

'Structure for file date/time
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

'Registry Function Prototypes
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 RegCloseKey Lib "advapi32" (ByVal hKey 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 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 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         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserevd As Long, lpType As Long, ByVal lpData As Long, lpcbData 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 RegQueryValueExLong Lib "advapi32.dll" 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.dll" 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 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, ByVal lpSecurityAttributes As Long, 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, 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 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
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, lpSecurityAttributes As Any) As Long
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) 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

'Winhelp declaration
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
'Get windows directory
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'Enumeration for the registry classes
Public Enum ERegistryClassConstants
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

'Enumeration for the registry values
Public Enum ERegistryValueTypes
    REG_NONE = 0                       ' No defined value type
    REG_SZ = 1                         ' A null-terminated string. It will be a Unicode or ANSI string
                                       ' depending on whether you use the Unicode or ANSI functions.
    REG_EXPAND_SZ = 2                  ' A null-terminated string that contains unexpanded references
                                       ' to environment variables (for example, "%PATH%"). It will be a Unicode or ANSI string
                                       ' depending on whether you use the Unicode or ANSI functions.
    REG_DWORD = 4                      ' A 32-bit number
    REG_DWORD_LITTLE_ENDIAN = 4        ' 32-bit number (same as REG_DWORD)
    REG_DWORD_BIG_ENDIAN = 5           ' 32-bit number
End Enum

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Enumerate subkeys under specified key  |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function EnumerateKeys(cClassKey As ERegistryClassConstants, SKey As String, ByRef sKeyNames() As String, lKeyCount As Long) As Long
    Dim lresult As Long         'Result of functions
    Dim hKey As Long            'Handle to objects
    Dim szBuffer As String      'Temporary buffer
    Dim lBuffSize As Long       'Size of buffer
    Dim lIndex As Long          'Index to keys to be enumerated
    Dim iPos As Long            'Position of found characters - used in Instr function
    Dim lNumOfKeys As Long      'Count of the number of keys found
   
    On Error GoTo EnumerateKeysError

    'Initialise
    lNumOfKeys = 0
    lIndex = 0
    lKeyCount = 0
    Erase sKeyNames
   
   
    'Open key
    lresult = RegOpenKeyEx(cClassKey, SKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
    Do While lresult = ERROR_SUCCESS
        'Set buffer space to hold found key names
        szBuffer = String$(255, 0)
        lBuffSize = Len(szBuffer)

        'Enumerate the key to get the next sunkey name
        lresult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)

        'If subkey is found, but it into the array
        If (lresult = ERROR_SUCCESS) Then
            lNumOfKeys = lNumOfKeys + 1
            ReDim Preserve sKeyNames(1 To lNumOfKeys) As String
           
            'Trim the name of the found subkey
            iPos = InStr(szBuffer, Chr$(0))
            If (iPos > 0) Then
                sKeyNames(lNumOfKeys) = Left(szBuffer, iPos - 1)
            Else
                sKeyNames(lNumOfKeys) = Left(szBuffer, lBuffSize)
            End If
        End If
       
        lKeyCount = lIndex
        lIndex = lIndex + 1
    Loop
   
    'Close key
    If (hKey <> 0) Then
        RegCloseKey hKey
    End If
   
    'Adjust for proper return value
    If lresult = ERROR_NO_MORE_ITEMS Then
        lresult = 0
    End If
   
    EnumerateKeys = lresult
Exit Function
   
EnumerateKeysError:

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

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Enumerate values under specified key   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function EnumerateValues(cClassKey As ERegistryClassConstants, SKey As String, sValueNames() As String, vValues() As Variant, lValueCount As Long) As Long
    Dim lresult As Long         'Return value of function
    Dim hKey As Long            'Handle to objects
    Dim sName As String         'Holds found value names
    Dim lNameSize As Long       'Size of found value names
    Dim lIndex As Long          'Index of the found value
    Dim cJunk As Long           'Not required
    Dim cNameMax As Long        'Length of the longest found values name
    Dim ft As Currency          'File date and time
   
    On Error GoTo EnumerateValuesError:
   
    'Initialise variables
    Erase sValueNames()
    Erase vValues()
    lIndex = 0
    lValueCount = 0
   
    'Open the key
    lresult = RegOpenKeyEx(cClassKey, SKey, 0, KEY_QUERY_VALUE, hKey)
   
    If (lresult = ERROR_SUCCESS) Then
        'Get key information
        lresult = RegQueryInfoKey(hKey, "", cJunk, 0&, cJunk, cJunk, cJunk, cJunk, cNameMax, cJunk, cJunk, ft)
        Do While lresult = ERROR_SUCCESS
            'Set buffer space big enough to hold found value names
            lNameSize = cNameMax + 1
            sName = String$(lNameSize, 0)
            If (lNameSize = 0) Then
                lNameSize = 1
            End If
           
            'Enumerate values to get the next value
            lresult = RegEnumValue(hKey, lIndex, sName, lNameSize, 0&, 0&, 0&, 0&)
               
            If (lresult = ERROR_SUCCESS) Then
                'Trim found value name
                sName = Left$(sName, lNameSize)
                lIndex = lIndex + 1
                'Resize arrays
                ReDim Preserve sValueNames(1 To lIndex) As String
                ReDim Preserve vValues(1 To lIndex) As Variant
               
                'Put the value names in sValuenames array
                sValueNames(lIndex) = sName
                'Put the values in vValues array
                vValues(lIndex) = GetValue(cClassKey, SKey, sName)
                lValueCount = lIndex
            End If
        Loop
    End If
   
    'Close key
    If (hKey <> 0) Then
        RegCloseKey hKey
    End If
   
    'Adjust for proper return value
    If lresult = ERROR_NO_MORE_ITEMS Then
        lresult = 0
    End If
   
    EnumerateValues = lresult
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

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Swap memory location for DWORD_BIG_ENDIAN Registry type   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Expand environment string in the case  |
'|   where value type is REG_EXPAND_SZ      |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function ExpandEnvStr(sData As String) As String
    Dim C As Long       'Function return value
    Dim s As String     'Expanded string
   
    ' Get the length
    s = ""              ' Needed to get around Windows 95 limitation
   
    ' Expand the string
    C = ExpandEnvironmentStrings(sData, s, C)
    s = String$(C - 1, 0)
    C = ExpandEnvironmentStrings(sData, s, C)
    ExpandEnvStr = s
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Delete an existing value   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function DeleteValue(cClassKey As ERegistryClassConstants, SKey, Optional vValueName As String = "") As Boolean
    Dim hKey As Long                'Handle to key
    Dim lRet As Long                'Function return value
    Dim sValueNames() As String     'Holds enumerated value names
    Dim vValues() As Variant        'Holds enumerated values
    Dim Count As Long               'Holds number of values found
    Dim i As Integer                'Loop counter
    Dim EnumKey As String           'Temporarily holds parameter 2 (sKey)
   
    EnumKey = SKey
   
    'Open the key where value to delete is
    lRet = RegOpenKeyEx(cClassKey, SKey, 0, KEY_ALL_ACCESS, hKey)
   
    If lRet Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key '" & cClassKey & "',Section: '" & SKey & "' for delete access"
    Else
        'If no value is specified or value is ""
        If vValueName = "" Then
            'Enumerate the key to see how many values are under it
            lRet = EnumerateValues(cClassKey, EnumKey, sValueNames, vValues, Count)
            'If any values are found, delete them
            If Count > 0 Then
                For i = 1 To UBound(sValueNames)
                    lRet = RegDeleteValue(hKey, sValueNames(i))
                Next i
            End If
        Else
            'If value is specified, then just delete it
            lRet = RegDeleteValue(hKey, vValueName)
        End If
       
        'Check for error
        If lRet Then
            Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & cClassKey & "',Section: '" & SKey & "',Key: '" & vValueName
        Else
            DeleteValue = (lRet = ERROR_SUCCESS)
        End If
    End If
   
    'Close the key
    If hKey <> 0 Then
        RegCloseKey hKey
    End If
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Delete an existing key   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function DeleteKey(cClassKey As ERegistryClassConstants, SKey As String, Optional bDeleteAllSubKeys As Boolean = False) As Boolean
    Dim lRet As Long            'Function return value
    Dim bRet As Boolean         'Function return value
    Dim SubKeys() As String     'Holds subkey names when enumerating them
    Dim i As Long               'Loop counter
    Dim Count As Long           'Number of subkeys found under key
   
    'If key exists, then enumerate the key to see if it has subkeys
    If KeyExists(cClassKey, SKey) Then
        lRet = EnumerateKeys(cClassKey, SKey, SubKeys, Count)
    Else
        'If key is not found
        DeleteKey = False
        Exit Function
    End If
   
    'If key has no subkeys, then delete key
    If Count = 0 Then
        'Delete key
        lRet = RegDeleteKey(cClassKey, SKey)
    Else        'Key has subkeys
        'If bDelteAllSubKeys is true
        If bDeleteAllSubKeys Then
            'Key has subkeys delete them recursively
            For i = 1 To UBound(SubKeys)
                bRet = DeleteKey(cClassKey, SKey & "\" & SubKeys(i), True)
            Next i
            'Delete the main key
            lRet = RegDeleteKey(cClassKey, SKey)
        Else
            'Key has more than one key, but the bDeleteAllSubKeys
            'boolean variable is false, so can't delete subkeys
            DeleteKey = False
            Exit Function
        End If
    End If
   
    If lRet Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & cClassKey & "',Section: '" & SKey
    Else
        DeleteKey = (lRet = ERROR_SUCCESS)
    End If
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Create a new empty key or open an existing one   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function CreateKey(cClassKey As ERegistryClassConstants, SKey As String) As Boolean
    Dim KeySecurity As SECURITY_ATTRIBUTES      'Key security
    Dim hKey As Long                            'Handle to key
    Dim lCreate As Long                         'Key status (whether created or opened)
    Dim lRet As Long                            'Function return value

    'Initialise key security
    KeySecurity.nLength = 50
    KeySecurity.lpSecurityDescriptor = 0
    KeySecurity.bInheritHandle = True
   
    'Open or Create the key
    lRet = RegCreateKeyEx(cClassKey, SKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lCreate)
   
    If lRet Then
        Err.Raise 26001, App.EXEName & ".cRegistry", " Failed to create registry Key: '" & SKey
    Else
        CreateKey = (lRet = ERROR_SUCCESS)
        RegCloseKey hKey
    End If
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Retrieve settings of an existing value name   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function GetValue(cClassKey As ERegistryClassConstants, SKey As String, sValueName As String) As Variant
    Dim vvalue As Variant       'Value setting found for value (sValueName)
    Dim cData As Long           'Buffer
    Dim sData As String         'Buffer
    Dim OrdType As Long         'Type of the data in value sValueName
    Dim lRet As Long            'Function return value
    Dim hKey As Long            'Handle to key

    'Open key
    lRet = RegOpenKeyEx(cClassKey, SKey, 0, KEY_QUERY_VALUE, hKey)
   
    'Query value (sValueName) to get its data type (OrdType)
    lRet = RegQueryValueExLong(hKey, sValueName, 0&, OrdType, 0&, cData)
   
    If lRet And lRet <> ERROR_MORE_DATA Then
        GetValue = VALUE_ERROR
        Exit Function
    End If

    'Check the data type and deal with it accordingly
    Select Case OrdType
        Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
            Dim lData As Long
           lRet = RegQueryValueExLong(hKey, sValueName, 0&, OrdType, lData, cData)
            vvalue = CLng(lData)
           
        Case REG_DWORD_BIG_ENDIAN
            Dim dwData As Long
            lRet = RegQueryValueExLong(hKey, sValueName, 0&, OrdType, dwData, cData)
            vvalue = SwapEndian(dwData)

        Case REG_SZ
            sData = String(cData, 0)
            lRet = RegQueryValueExString(hKey, sValueName, 0&, OrdType, sData, cData)
           
            If lRet = ERROR_SUCCESS Then
                vvalue = Left$(sData, cData - 1)
            Else
                vvalue = VALUE_ERROR
            End If
           
        Case REG_EXPAND_SZ
            sData = String(cData, 0)
            lRet = RegQueryValueExString(hKey, sValueName, 0&, OrdType, sData, cData)
           
            If lRet = ERROR_SUCCESS Then
                'Expand the environment string
                vvalue = ExpandEnvStr(sData)
            Else
                vvalue = VALUE_ERROR
            End If
                       
        ' Catch REG_BINARY and anything else
        Case Else
            Dim abData() As Byte
            ReDim abData(cData)
            lRet = RegQueryValueExByte(hKey, SKey, 0&, OrdType, abData(0), cData)
            vvalue = abData
    End Select
   
    GetValue = vvalue
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Set a new Value or replace an existing value for a value name   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function SetValue(cClassKey As ERegistryClassConstants, SKey As String, sValueName As String, lValueType As ERegistryValueTypes, Optional vValueSetting As Variant = "Value Not Set") As Boolean
    Dim lRetVal As Long     'Result of the SetValueEx Function
    Dim hKey As Long        'Handle to key
         
    'If key exists
    If KeyExists(cClassKey, SKey) Then
        'Open key
        lRetVal = RegOpenKeyEx(cClassKey, SKey, 0, KEY_ALL_ACCESS, hKey)
        'Set value
        lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
   
    'If key does not exist
    Else
        'Create key
        lRetVal = CreateKey(cClassKey, SKey)
        'Open key
        lRetVal = RegOpenKeyEx(cClassKey, SKey, 0, KEY_ALL_ACCESS, hKey)
        'Set value
        lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
    End If
   
    'Close key
    If hKey <> 0 Then
        RegCloseKey (hKey)
    End If
   
    SetValue = (lRetVal = ERROR_SUCCESS)
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   A wrapper function instead of direct API call for setting key values    |
'|   This function is used by the public function SetValue                   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, iType As Long, vvalue As Variant) As Long
    Dim OrdType As Long         'Data type (Registry data type) of value (sValueName)
    Dim C As Long
   
    On Error GoTo SetValueError:

    'Check the data type of value (sValueName)
    Select Case iType
        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
                'Set the value
                SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, OrdType, i, 4)
            Else
                SetValueEx = ERROR_INVALID_PARAMETER
            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
            'Set the value
            SetValueEx = RegSetValueExStr(hKey, sValueName, 0&, OrdType, s, C)

        'User should convert to a compatible type before calling
        Case Else
            SetValueEx = ERROR_INVALID_DATA
    End Select
Exit Function
   
SetValueError:
    Err.Raise 26001, App.EXEName & ".cRegistry", Err.Description
    Exit Function
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Check if a named key exists   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function KeyExists(cClassKey As ERegistryClassConstants, SKey As String) As Boolean
    Dim hKey As Long        'Handle to key
    Dim lRet As Long        'Function return value

    'Open key
    lRet = RegOpenKeyEx(cClassKey, SKey, 0, 1, hKey)
    KeyExists = (lRet = ERROR_SUCCESS)
   
    'Close key
    If hKey <> 0 Then
        RegCloseKey hKey
    End If
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Check if a named value exists   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function ValueExists(cClassKey As ERegistryClassConstants, SKey As String, sValueName As String) As Boolean
    Dim lRet As Long                'Function return value
    Dim sVNames() As String         'Holds value names found under key
    Dim vValues() As Variant        'Holds value settings
    Dim Count As Long               'Holds the number of values found under key
    Dim i As Long                   'Loop counter
   
    'Enumerate values for the key (sKey)
    lRet = EnumerateValues(cClassKey, SKey, sVNames, vValues, Count)
   
    'See if the value we are after is one of the enumerated values for key (sKey)
    For i = 1 To Count
        'Return true if value found in the array
        ValueExists = (UCase(sValueName) = UCase(sVNames(i)))
        If ValueExists = True Then
            Exit For
        End If
    Next i
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Return the type for the named value   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function ValueType(cClassKey As ERegistryClassConstants, SKey As String, sValueName As String) As ERegistryValueTypes
    Dim lRet As Long
    Dim hKey As Long
    Dim cData As Long
    Dim OrdType As Long

    'Open key
    lRet = RegOpenKeyEx(cClassKey, SKey, 0, KEY_QUERY_VALUE, hKey)
    'Query value to get its data type
    lRet = RegQueryValueExLong(hKey, sValueName, 0&, OrdType, 0&, cData)

    ValueType = OrdType
   
    'Close key
    If (hKey <> 0) Then
        RegCloseKey hKey
    End If
End Function

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'|   Return windows directory   |
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function GetWinDir() As String
    Dim sWinDir As String
    Dim lSize As Long
    Dim lRet As Long
   
    'Set buffer
    lSize = MAX_PATH
    sWinDir = String$(lSize, 0)
   
    'Get windows directory
    lRet = GetWindowsDirectory(sWinDir, lSize)
   
    'Trim buffer
    If sWinDir <> "" Then
        sWinDir = Left(sWinDir, lRet)
    End If
       
    GetWinDir = sWinDir
End Function

0
 
LVL 12

Expert Comment

by:gbzhhu
ID: 13494865
It is one class that you can add to your project

To use DWORD simply pass SetValue function lValueType parameter a value of REG_DWORD (type ERegistryValueTypes)

I never tested this as I only use REG_SZ but it should work
0
 

Author Comment

by:jclothier
ID: 13494967
Thanks to BlueDevilFan , sorry I was accepting the other answer as you were writing yours.

Thanks to gbzhhu for everything I could possibly ever need with the Registry!
0
 
LVL 12

Expert Comment

by:gbzhhu
ID: 13495402
jclothier

No problemo my friend and if you need any help using my class, I have written a help file .hlp almost identical to VB's that covers all the methods, paramaters, return value.  If you want it let me have an email address and I will send it to you, since we cannot put files here on EE

Cheers
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
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…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses
Course of the Month9 days, 9 hours left to enroll

762 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