registry.bas

Custom Visual Basic Packager and Installer for Visual Basic Developers. This is a group of standard

Attribute VB_Name = "modRegistry"
Option Explicit
Option Compare Text

Global Const gsSLASH_BACKWARD As String = "\"

''Registry API Declarations...
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey 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, _
    ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, _
    ByRef lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
    ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32" Alias "RegEnumValueA" _
    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
    ByRef lpcbValueName As Long, ByVal lpReserved As Long, ByRef lpType As Long, _
    ByVal lpData As String, ByRef lpcbData 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 Long, _
    ByVal lpcbClass As Long, lpftLastWriteTime As FileTime) As Long

''Reg Data Types...
Private Const REG_NONE = 0                                          ' No value type
Private Const REG_SZ = 1                                            ' Unicode nul terminated string
Private Const REG_EXPAND_SZ = 2                                     ' Unicode nul terminated string
Private Const REG_BINARY = 3                                        ' Free form binary
Private Const REG_DWORD = 4                                         ' 32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN = 4                           ' 32-bit number (same as REG_DWORD)
Private Const REG_DWORD_BIG_ENDIAN = 5                              ' 32-bit number
Private Const REG_LINK = 6                                          ' Symbolic Link (unicode)
Private Const REG_MULTI_SZ = 7                                      ' Multiple Unicode strings
Private Const REG_RESOURCE_LIST = 8                                 ' Resource list in the resource map
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9                      ' Resource list in the hardware description
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10

''Reg Create Type Values...
Private Const REG_OPTION_RESERVED = 0                               ' Parameter is reserved
Private Const REG_OPTION_NON_VOLATILE = 0                           ' Key is preserved when system is rebooted
Private Const REG_OPTION_VOLATILE = 1                               ' Key is not preserved when system is rebooted
Private Const REG_OPTION_CREATE_LINK = 2                            ' Created key is a symbolic link
Private Const REG_OPTION_BACKUP_RESTORE = 4                         ' open for backup or restore

''Reg Key Security Options...
Private Const READ_CONTROL = &H20000
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_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE _
                            + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS _
                            + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

''Return Value...
Private Const ERROR_SUCCESS = 0
Private Const ERROR_ACCESS_DENIED = 5&
Private Const ERROR_NO_MORE_ITEMS = 259&

''Hierarchy separator
Private Const KeySeparator As String = "\"

''Registry Security Attributes TYPE...
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

''Reg Key ROOT Types...
Public Enum REGToolRootTypes
    HK_CLASSES_ROOT = &H80000000
    HK_CURRENT_USER = &H80000001
    HK_LOCAL_MACHINE = &H80000002
    HK_USERS = &H80000003
    HK_PERFORMANCE_DATA = &H80000004
    HK_CURRENT_CONFIG = &H80000005
    HK_DYN_DATA = &H80000006
End Enum

'Retrieves a key value.
Public Function GetKeyValue(ByVal KeyRoot As REGToolRootTypes, KeyName As String, ValueName As String, ByRef ValueData As String) As Boolean
    Dim i As Long                                                   ' Loop Counter
    Dim hKey As Long                                                ' Handle To An Open Registry Key
    Dim KeyValType As Long                                          ' Data Type Of A Registry Key
    Dim sTmp As String                                              ' Tempory Storage For A Registry Key Value
    Dim sReturn As String
    Dim KeyValSize As Long                                          ' Size Of Registry Key Variable
    Dim sByte As String

    If ValidKeyName(KeyName) Then
        On Error GoTo LocalErr

        ' Open registry key under KeyRoot
        Attempt RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)

        sTmp = String$(1024, 0)                                         ' Allocate Variable Space
        KeyValSize = 1024                                               ' Mark Variable Size

        ' Retrieve Registry Key Value...
        Attempt RegQueryValueEx(hKey, ValueName, 0, _
                KeyValType, sTmp, KeyValSize)                           ' Get/Create Key Value

        If (Asc(Mid(sTmp, KeyValSize, 1)) = 0) Then                     ' Win95 Adds Null Terminated String...
            sTmp = Left(sTmp, KeyValSize - 1)                           ' Null Found, Extract From String
        Else                                                            ' WinNT Does NOT Null Terminate String...
            sTmp = Left(sTmp, KeyValSize)                               ' Null Not Found, Extract String Only
        End If

        ' Determine Key Value Type For Conversion...
        Select Case KeyValType                                          ' Search Data Types...
            Case REG_SZ                                                 ' String Registry Key Data Type
                sReturn = sTmp '(Do nothing)
            Case REG_DWORD                                              ' Double Word Registry Key Data Type
                For i = Len(sTmp) To 1 Step -1                          ' Convert Each Bit
                    sByte = Hex(Asc(Mid$(sTmp, i, 1)))
                    Do Until Len(sByte) = 2
                        sByte = "0" & sByte
                    Loop
                    sReturn = sReturn & sByte                           ' Build Value Char. By Char.
                Next
                sReturn = Format$("&h" + sReturn)                       ' Convert Double Word To String
        End Select

        GetKeyValue = True
        ValueData = sReturn

LocalErr:
        On Error Resume Next
        RegCloseKey hKey
    End If
End Function

Private Sub Attempt(rc As Long)
    If (rc <> ERROR_SUCCESS) Then
        Err.Raise 5
    End If
End Sub

Private Function ValidKeyName(KeyName As String) As Boolean
    'A key name is invalid if it begins or ends with \ or contains \\
    If Left$(KeyName, 1) <> gsSLASH_BACKWARD Then
        If Right$(KeyName, 1) <> gsSLASH_BACKWARD Then
            If InStr(KeyName, gsSLASH_BACKWARD & gsSLASH_BACKWARD) = 0 Then
                ValidKeyName = True
            End If
        End If
    End If
End Function