'===========================================================================
' Subject: WRAPPER FOR WIN9X REGISTRY API    Date: 05-13-00 (15:32)       
' Author:  Jeremiah Hyde                     Code: VB5                    
' Origin:  fishoffire@yahoo.com            Packet: VBWIN.ABC
'===========================================================================
Attribute VB_Name = "Registry"
'PPPPPP
'PP  PP
'PP  PP  rr rrr   oooo    ggg gg  rr rrr   aaaa   mm  mm    eeee   rr rrr   zzzzzz
'PPPPP    rrr rr oo  oo  gg  gg    rrr rr     aa  mmmmmmm  ee  ee   rrr rr  z  zz
'PP       rr  rr oo  oo  gg  gg    rr  rr  aaaaa  mmmmmmm  eeeeee   rr  rr    zz
'PP       rr     oo  oo   ggggg    rr     aa  aa  mm m mm  ee       rr       zz  z
'PP      rrrr     oooo       gg   rrrr     aaaaa  mm   mm   eeee   rrrr     zzzzzz
'                         ggggg                               (  /\__________/\  )
'   ###########                                                \(^ @___..___@ ^)/
'   # ___ ___ #   RRRRR            lll            !!   !!       /\ (\/\/\/\/) /\
'   { (0) (0) }   RR  RR            ll           !!!! !!!!     /  \(/\/\/\/\)/  \
'   |    P    |   RR  RR  uu  uu    ll   zzzzzz  !!!! !!!!   -(    """"""""""    )
'    \ \___/ /    RRRRR   uu  uu    ll   z  zz   !!!! !!!!    \      _____      /
'      \___/      RR RR   uu  uu    ll     zz     !!   !!     (     /(   )\     )
'  Jeremiah "BJ"  RR  RR  uu  uu    ll    zz  z               _)   (_V) (V_)   (_
'      Hyde       RR  RR   uuu uu  llll  zzzzzz   !!   !!    (V)(V)(V)   (V)(V)(V)
'                                                         My dog Smokey(Brainless Mutt)
'
' This code released under the GNU General Public License. This means you can use it,
' compile it, pass it around, modify it, WHATEVER! However, if you do this, I will
' expect notification and a copy of whatever you've done, unless it's a virus, or
' breaking into the CIA, etc. Also, there should be a prominent display in the program,
' visible to users, stating that I am responsible for that part of the program.
'                                                    Jeremiah "BJ" Hyde
' E-Mail me at: fishoffire@yahoo.com               fishoffire Industries:
'Visit me at: www.geocities.com/fishoffire/           Your source for
'                                                    EVERYTHING QBasic
'Note:
' This code has been tested on one machine(An AMD K6-266, 32MB RAM, 4.2GB HD, 15"
' PnP Monitor, Win95 DOS Box), and has run correctly there. However, no guarantee,
' warranty, or other declaration of safety, etc. is offered. If your computer system
' is taken over by smurfs, or the PROM is zapped, or anything else of a detrimental
' nature happens to your system as a result of this code, I am not responsible for
' it. The full burden of blame rests on your shoulders. (Of course, if something
' GOOD happens to your computer as a result of this code, well, obviously, I did it!)

' This module is a wrapper for the Win9x Registry API. Most of the time, you can
' safely use this as a "black box," without even understanding it. However, I think
' the code is clear enough to expand, if you want. If this code is too difficult to
' use, then try to find my EasyReg.bas, which provides Drop-In replacements for VB's
' native registry support(Should be in the same place you got this from).
Option Explicit
Public Enum HKEY_BASE
    [_hkMin] = &H80000000
    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
    [_hkMax] = &H80000006
End Enum
Private Const ERROR_SUCCESS = 0&

Private Const REG_SZ = 1
Private Const REG_DWORD = 4

Global Const regError = 4096
Global Const regCloseKeyErr = regError + 1
Global Const regCreateKeyErr = regError + 2
Global Const regDeleteKeyErr = regError + 3
Global Const regEnumKeyErr = regError + 4
Global Const regOpenKeyErr = regError + 5
Global Const regQueryStringValueErr = regError + 6
Global Const regQueryNumericValueErr = regError + 7
Global Const regSetStringValueErr = regError + 8
Global Const regSetNumericValueErr = regError + 9

Private Declare Function OSRegCloseKey Lib "advapi32" Alias "RegCloseKey" (ByVal HKEY As Long) As Long
Private Declare Function OSRegCreateKey Lib "advapi32" Alias "RegCreateKeyA" (ByVal HKEY As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Private Declare Function OSRegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" (ByVal HKEY As Long, ByVal lpszSubKey As String) As Long
Private Declare Function OSRegEnumKey Lib "advapi32" Alias "RegEnumKeyA" (ByVal HKEY As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long
Private Declare Function OSRegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal HKEY As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Private Declare Function OSRegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal HKEY As Long, ByVal lpszValueName As String, ByVal dwReserved As Long, lpdwType As Long, lpbData As Any, cbData As Long) As Long
Private Declare Function OSRegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal HKEY As Long, ByVal lpszValueName As String, ByVal dwReserved As Long, ByVal fdwType As Long, lpbData As Any, ByVal cbData As Long) As Long

Public Sub RegCloseKey(ByVal hOpenKey As Long)
' Closes an open registry key.
    If OSRegCloseKey(hOpenKey) = ERROR_SUCCESS Then
        ' We succeeded, nothing more to do
    Else
        ' We failed, throw an error
        Err.Raise regCloseKeyErr, , "Unable to close key. RegCloseKey failed."
    End If
End Sub

Public Function RegCreateKey(ByVal hKeyRoot As Long, ByVal lpszSubKey As String) As Long
' Opens (creates if already exists) a key in the system registry.
' Returns the handle of the opened or created key
    Dim phkResult As Long
    If OSRegCreateKey(hKeyRoot, lpszSubKey, phkResult) = ERROR_SUCCESS Then
        ' Successfully created key, return hKey
        RegCreateKey = phkResult
    Else
        ' There was an error, throw it
        Err.Raise regCreateKeyErr, , "Unable to create(or open) key """ & lpszSubKey & """. RegCreateKey failed."
    End If
End Function

Public Sub RegDeleteKey(ByVal hKeyRoot As Long, ByVal lpszSubKey As String)
' Deletes an existing key in the system registry.
' Must recursively delete from key passed through
' all subkeys to handle WinNT.
    Dim hOpenKey As Long, iIndex As Long, strSubKey As String
    hOpenKey = RegOpenKey(hKeyRoot, lpszSubKey)
    iIndex = 0
    Do
        On Error Resume Next: Err.Clear
        strSubKey = RegEnumKey(hOpenKey, iIndex)
        If Err Then Exit Do ' End of keys to delete
        iIndex = iIndex + 1
        RegDeleteKey hKeyRoot, lpszSubKey & "\" & strSubKey
    Loop
    RegCloseKey hOpenKey
    If OSRegDeleteKey(hKeyRoot, lpszSubKey) = ERROR_SUCCESS Then
        ' We succeeded, nothing more to do
    Else
        ' We failed, throw an error
        Err.Raise regDeleteKeyErr, , "Unable to delete key " & GetRootHKEYString(hKeyRoot) & "\" & lpszSubKey & ". RegDeleteKey failed."
    End If
End Sub

Public Function RegEnumKey(ByVal hOpenKey As Long, ByVal i As Long) As String
' Enumerates through the subkeys of an open registry
' key (returns the "i"th subkey of hkey, if it exists)
    Dim strResult As String
    
    strResult = Space(300)
    If OSRegEnumKey(hOpenKey, i, strResult, Len(strResult)) = ERROR_SUCCESS Then
        ' Yup, that key index exists
        RegEnumKey = StripTerminator(strResult)
    Else
        ' Nope, throw an error
        Err.Raise regEnumKeyErr, , "Could not find subkey with index of " & i & ". RegEnumKey failed."
    End If
End Function

Public Function RegOpenKey(ByVal hKeyRoot As Long, ByVal lpszSubKey As String) As Long
' Opens an existing key in the system registry.
    Dim phkResult As Long
    If OSRegOpenKey(hKeyRoot, lpszSubKey, phkResult) = ERROR_SUCCESS Then
        ' We succeeded! Throw a party!!! And, return the hKey
        RegOpenKey = phkResult
    Else
        ' We failed! Throw an error!!!
        Err.Raise regOpenKeyErr, , "Unable to open key """ & GetRootHKEYString(hKeyRoot) & "\" & lpszSubKey & """. RegOpenKey failed."
    End If
End Function

Public Function RegQueryStringValue(ByVal hOpenKey As Long, ByVal strValueName As String) As String
' Retrieves the string data for a named
' (strValueName = name) or unnamed (strValueName = "")
' value within a registry key.  If the named value
' exists, but its data is not a string, this function
' fails.
    Dim lValueType As Long
    Dim strBuf As String
    Dim lDataBufSize As Long
    
    ' Get length/data type
    If OSRegQueryValueEx(hOpenKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize) = ERROR_SUCCESS Then
        If lValueType = REG_SZ Then
            strBuf = String(lDataBufSize, " ")
            If OSRegQueryValueEx(hOpenKey, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize) = ERROR_SUCCESS Then
                RegQueryStringValue = StripTerminator(strBuf)
            Else
                Err.Raise regQueryStringValueErr, , "Could not retrieve data for key """ & strValueName & """. RegQueryValueEx failed."
            End If
        Else
            Err.Raise regQueryStringValueErr, , "RegQueryStringValue cannot retrieve non-string data. """ & strValueName & """ is non-string data."
        End If
    Else
        Err.Raise regQueryStringValueErr, , "Could not determine data type/size for key """ & strValueName & """. RegQueryValueEx failed."
    End If
End Function

Public Function RegQueryNumericValue(ByVal hOpenKey As Long, ByVal strValueName As String) As Long
' Retrieves the integer data for a named
' (strValueName = name) or unnamed (strValueName = "")
' value within a registry key.  If the named value
' exists, but its data is not a REG_DWORD, this function
' fails.
    Dim lResult As Long
    Dim lValueType As Long
    Dim lBuf As Long
    Dim lDataBufSize As Long
    
    ' Get length/data type
    lDataBufSize = 4
    If OSRegQueryValueEx(hOpenKey, strValueName, 0&, lValueType, lBuf, lDataBufSize) = ERROR_SUCCESS Then
        If lValueType = REG_DWORD Then
            RegQueryNumericValue = lBuf
        Else
            Err.Raise regQueryNumericValueErr, , "RegQueryNumericValue cannot return data that is not of REG_DWORD(&H" & Hex(REG_DWORD) & "&) type. """ & strValueName & """ is not of REG_DWORD type."
        End If
    Else
        Err.Raise regQueryNumericValueErr, , "Could not retrieve data for """ & strValueName & """. RegQueryValueEx failed."
    End If
End Function

Public Sub RegSetStringValue(ByVal hOpenKey As Long, ByVal strValueName As String, ByVal strValueData As String)
' Associates a named (strValueName = name) or unnamed (strValueName = "")
'   value with a registry key.
    If OSRegSetValueEx(hOpenKey, strValueName, 0&, REG_SZ, ByVal strValueData, Len(strValueData) + 1) = ERROR_SUCCESS Then
        ' We succeeded, do nothing
    Else
        ' We failed, throw an error(no, I did not say tantrum!)
        Err.Raise regSetStringValueErr, , "Unable to set """ & strValueName & """ to the value """ & strValueData & """. RegSetValueEx failed."
    End If
End Sub

Public Sub RegSetNumericValue(ByVal hOpenKey As Long, ByVal strValueName As String, ByVal lValueData As Long)
' Associates a named (strValueName = name) or unnamed (strValueName = "")
'   value with a registry key.
    If OSRegSetValueEx(hOpenKey, strValueName, 0&, REG_DWORD, lValueData, 4) = ERROR_SUCCESS Then
        ' We succeeded, do nothing
    Else
        ' We failed, throw an error
        Err.Raise regSetNumericValueErr, , "Unable to set """ & strValueName & """ to the value " & lValueData & ". RegSetValueEx failed."
    End If
End Sub

Private Function GetRootHKEYString(ByVal HKEY As Long) As String
'Given a root HKEY, return the text string representing that
'key, or else return "".
    Select Case HKEY
        Case HKEY_CLASSES_ROOT
            GetRootHKEYString = "HKEY_CLASSES_ROOT"
        Case HKEY_CURRENT_USER
            GetRootHKEYString = "HKEY_CURRENT_USER"
        Case HKEY_LOCAL_MACHINE
            GetRootHKEYString = "HKEY_LOCAL_MACHINE"
        Case HKEY_USERS
            GetRootHKEYString = "HKEY_USERS"
    End Select
End Function

Private Function GetRootHKEYVal(ByVal HKEY As String) As Long
' Given a string root HKEY, return the long
' HKEY value(used for Reg calls) for it. If
' not found, return -1. Allows abbreviations
' for ease of use.
Select Case LCase(Trim(HKEY))
    Case "hkey_classes_root", "hkcr"
        GetRootHKEYVal = HKEY_CLASSES_ROOT
    Case "hkey_current_user", "hkcu"
        GetRootHKEYVal = HKEY_CURRENT_USER
    Case "hkey_local_machine", "hklm"
        GetRootHKEYVal = HKEY_LOCAL_MACHINE
    Case "hkey_users", "hku"
        GetRootHKEYVal = HKEY_USERS
End Select
End Function

Private Function StripTerminator(ByVal strString As String) As String
' Returns a string without any zero terminator.  Typically,
' this was a string returned by a Windows API call.
    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

Private Function Parse(Pos As Long, Work As String, Delimit As String) As String
' Splits a string into chunks, delimited by Delimit, and returns the requested one.
If InStr(Work, Delimit) > 0 Then
    If Pos = 0 Then
        Parse = Mid(Work, 1, InStr(Work, Delimit) - 1)
    ElseIf Pos <> 0 Then
        Dim sTemp As String
        sTemp = Mid(Work, InStr(Work, Delimit) + Len(Delimit))
        Parse = Parse(Pos - 1, sTemp, Delimit)
    End If
Else
    Parse = Work
End If
End Function