Results 1 to 17 of 17

Thread: Reading, Writing, Registry

  1. #1

    Thread Starter
    New Member
    Join Date
    Nov 2000
    Posts
    10

    Question

    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
    TTFN,

    Smashing Piggy

    "Beware of Big Bad Wolf dressed in Tigger clothes"

  2. #2
    Fanatic Member
    Join Date
    Feb 2000
    Location
    The Netherlands
    Posts
    715
    I think this will help you.
    Oetje
    oetje@home.nl
    93606776
    Visual Basic 6, Windows 2000

    Never pet a burning dog

  3. #3
    New Member
    Join Date
    Nov 2000
    Posts
    7
    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...
    Code:
    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...
    Code:
    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..
    Code:
    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.

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

  4. #4
    Fanatic Member
    Join Date
    Oct 2000
    Location
    London
    Posts
    1,008
    Glad there wasn't TOO much code to run through - I'd have never understood it otherwise <grin>

    P.
    Not nearly so tired now...

    Haven't been around much so be gentle...

  5. #5
    Fanatic Member
    Join Date
    Feb 2000
    Location
    The Netherlands
    Posts
    715
    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'.
    Oetje
    oetje@home.nl
    93606776
    Visual Basic 6, Windows 2000

    Never pet a burning dog

  6. #6

    Thread Starter
    New Member
    Join Date
    Nov 2000
    Posts
    10
    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)
    TTFN,

    Smashing Piggy

    "Beware of Big Bad Wolf dressed in Tigger clothes"

  7. #7
    New Member
    Join Date
    Nov 2000
    Posts
    7
    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...
    Code:
    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.

  8. #8

    Thread Starter
    New Member
    Join Date
    Nov 2000
    Posts
    10
    oetje,

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

    Thanks again.

    TTFN,

    Smashing Piggy

    "Beware of Big Bad Wolf dressed in Tigger clothes"

  9. #9

    Thread Starter
    New Member
    Join Date
    Nov 2000
    Posts
    10
    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.

    TTFN,

    Smashing Piggy

    "Beware of Big Bad Wolf dressed in Tigger clothes"

  10. #10
    Guest
    Code for a Module.
    Code:
    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:
    Code:
    '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

  11. #11
    Fanatic Member
    Join Date
    May 2001
    Posts
    525
    i love you megatron. (translated-you really helped me out a lot.)

  12. #12
    Junior Member
    Join Date
    Nov 2000
    Location
    Marietta GA
    Posts
    20

    The Registry Class - You will Learn to Love it

    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.

  13. #13
    Junior Member
    Join Date
    Nov 2000
    Location
    Marietta GA
    Posts
    20

    Registry Class (Part I)

    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

  14. #14
    Junior Member
    Join Date
    Nov 2000
    Location
    Marietta GA
    Posts
    20

    Registry Class (Part II)

    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

  15. #15
    Junior Member
    Join Date
    Nov 2000
    Location
    Marietta GA
    Posts
    20

    Registry Class (Part III)

    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

  16. #16
    Junior Member
    Join Date
    Nov 2000
    Location
    Marietta GA
    Posts
    20

    Thats it

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

  17. #17
    Monday Morning Lunatic parksie's Avatar
    Join Date
    Mar 2000
    Location
    Mashin' on the motorway
    Posts
    8,169
    Couldn't you just have attached it? Or at least put it in code tags Looks good though
    I refuse to tie my hands behind my back and hear somebody say "Bend Over, Boy, Because You Have It Coming To You".
    -- Linus Torvalds

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width