Registry.bas

   1 Attribute VB_Name = "RegistryFunctions"
   2 Option Explicit
   3
   4 Private Const HKEY_CLASSES_ROOT = &H80000000
   5 Private Const HKEY_CURRENT_USER = &H80000001
   6 Private Const HKEY_LOCAL_MACHINE = &H80000002
   7 Private Const HKEY_USERS = &H80000003
   8 Private Const HKEY_PERFORMANCE_DATA = &H80000004
   9 Private Const HKEY_CURRENT_CONFIG = &H80000005
  10 Private Const HKEY_DYN_DATA = &H80000006
  11 Private Const STANDARD_RIGHTS_ALL = &H1F0000
  12 Private Const KEY_QUERY_VALUE = &H1
  13 Private Const KEY_SET_VALUE = &H2
  14 Private Const KEY_CREATE_SUB_KEY = &H4
  15 Private Const KEY_ENUMERATE_SUB_KEYS = &H8
  16 Private Const KEY_NOTIFY = &H10
  17 Private Const SYNCHRONIZE = &H100000
  18 Private Const KEY_CREATE_LINK = &H20
  19 Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
  20     KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY _
  21     Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or _
  22     KEY_CREATE_LINK) And (Not SYNCHRONIZE))
  23 Private Const REG_OPTION_NON_VOLATILE = 0
  24 Global Const REG_NONE = 0
  25 Global Const REG_SZ = 1
  26 Global Const REG_EXPAND_SZ = 2
  27 Global Const REG_BINARY = 3
  28 Global Const REG_DWORD = 4
  29 Global Const REG_DWORD_LITTLE_ENDIAN = 4 ' Same as REG_DWORD
  30 Global Const REG_DWORD_BIG_ENDIAN = 5
  31 Global Const REG_LINK = 6
  32 Global Const REG_MULTI_SZ = 7
  33 Global Const REG_RESOURCE_LIST = 8
  34 Global Const REG_FULL_RESOURCE_DESCRIPTOR = 9
  35 Global Const REG_RESOURCE_REQUIREMENTS_LIST = 10
  36
  37 Private Const REG_CREATED_NEW_KEY = &H1
  38 Private Const REG_OPENED_EXISTING_KEY = &H2
  39
  40 Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
  41     (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
  42     ByVal samDesired As Long, phkResult As Long) As Long
  43 Private Declare Function RegCloseKey Lib "advapi32.dll" _
  44     (ByVal hKey As Long) As Long
  45 Private Declare Function RegEnumValue Lib "advapi32.dll" _
  46     Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex _
  47     As Long, lpValueName As String, lpcbValueName As Long, ByVal _
  48     lpReserved As Long, lpType As Long, lpData As Any, lpcbData As _
  49     Long) As Long
  50 Private Declare Function RegEnumKeyEx Lib "advapi32.dll" _
  51     Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex _
  52     As Long, lpName As String, lpcbName As Long, ByVal _
  53     lpReserved As Long, lpClass As String, lpcbClass As _
  54     Long, lpftLastWriteTime As Any) As Long
  55 Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
  56     Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _
  57     As String, ByVal lpReserved As Long, lpType As Long, lpData As _
  58     Any, lpcbData As Long) As Long
  59 Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
  60     Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey _
  61     As String, ByVal Reserved As Long, ByVal lpClass As String, _
  62     ByVal dwOptions As Long, ByVal samDesired As Long, _
  63     lpSecurityAttributes As Any, phkResult _
  64     As Long, lpdwDisposition As Long) As Long
  65 Private Declare Function RegSetValueEx Lib "advapi32.dll" _
  66     Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
  67     As String, ByVal Reserved As Long, ByVal dwType As Long, _
  68     lpData As Any, ByVal cbData As Long) As Long
  69 Private Declare Function RegDeleteValue Lib "advapi32.dll" _
  70     Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _
  71     lpValueName As String) As Long
  72 Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
  73     "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  74 Sub ConvertValueName(Path As String, ByRef hKey As Long, ByRef Key As String, ValueName As String)
  75 Dim Data As String, bNum As Long
  76 Data = Mid$(Path, 1, InStr(Path, "\") - 1)
  77 Select Case Data
  78 Case "HKEY_CLASSES_ROOT"
  79 hKey = HKEY_CLASSES_ROOT
  80 Case "HKEY_CURRENT_USER"
  81 hKey = HKEY_CURRENT_USER
  82 Case "HKEY_LOCAL_MACHINE"
  83 hKey = HKEY_LOCAL_MACHINE
  84 Case "HKEY_USERS"
  85 hKey = HKEY_USERS
  86 Case "HKEY_PERFORMANCE_DATA"
  87 hKey = HKEY_PERFORMANCE_DATA
  88 Case "HKEY_CURRENT_CONFIG"
  89 hKey = HKEY_CURRENT_CONFIG
  90 Case "HKEY_DYN_DATA"
  91 hKey = HKEY_DYN_DATA
  92 End Select
  93 bNum = 1
  94 Do Until InStr(bNum, Path, "\") = 0
  95 bNum = InStr(bNum, Path, "\") + 1
  96 Loop
  97 On Error Resume Next
  98 Key = Mid$(Path, Len(Data) + 2, bNum - 2 - (Len(Data) + 1))
  99 ValueName = Mid$(Path, bNum)
 100 On Error GoTo 0
 101 End Sub
 102 Function GetReg(Path As String, Optional Default)
 103 Attribute GetReg.VB_Description = "Reads a value from the registry."
 104 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long, vType As Long, NumData As Long
 105 ConvertValueName Path, hKey, Key, ValueName
 106 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then
 107     If RegQueryValueEx(kHandle, ValueName, 0&, vType, ByVal 0&, vLen) = 0 Then
 108         Data = String$(vLen, Chr$(0))
 109         If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then
 110             If RegQueryValueEx(kHandle, ValueName, 0&, 0&, NumData, vLen) = 0 Then
 111                 GetReg = NumData
 112             End If
 113         Else
 114             If RegQueryValueEx(kHandle, ValueName, 0&, 0&, ByVal Data, vLen) = 0 Then
 115                 If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then
 116                     Data = Left$(Data, vLen - 1)
 117                     If Data <> "" Then GetReg = Data
 118                 Else
 119                     GetReg = Data
 120                 End If
 121             End If
 122         End If
 123     End If
 124     RegCloseKey kHandle
 125     If Not IsEmpty(GetReg) Then Exit Function
 126 End If
 127 If Not IsError(Default) Then GetReg = Default
 128 End Function
 129 Function GetRegType(Path As String) As Long
 130 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long, vType As Long
 131 ConvertValueName Path, hKey, Key, ValueName
 132 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then
 133     If RegQueryValueEx(kHandle, ValueName, 0&, vType, ByVal 0&, ByVal 0&) Then
 134         GetRegType = vType
 135     End If
 136     RegCloseKey kHandle
 137 End If
 138 End Function
 139 Function EnumReg(ByVal Path As String, Index As Long) As String
 140 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long
 141 If Right$(Path, 1) <> "\" Then Path = Path + "\"
 142 ConvertValueName Path, hKey, Key, ValueName
 143 ValueName = ""
 144 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then
 145     vLen = 255
 146     Data = String$(255, Chr$(0))
 147     If RegEnumValue(kHandle, Index, ByVal Data, vLen, 0&, 0&, ByVal 0&, 0&) = 0 Then
 148         Data = Left$(Data, vLen)
 149         If Data = String$(255, Chr$(0)) Then Data = ""
 150         EnumReg = Data
 151     End If
 152     RegCloseKey kHandle
 153 End If
 154 End Function
 155 Function EnumKey(ByVal Path As String, Index As Long) As String
 156 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long
 157 If Right$(Path, 1) <> "\" Then Path = Path + "\"
 158 ConvertValueName Path, hKey, Key, ValueName
 159 ValueName = ""
 160 If RegOpenKeyEx(hKey, Key, 0&, KEY_ENUMERATE_SUB_KEYS, kHandle) = 0 Then
 161     vLen = 255
 162     Data = String$(255, Chr$(0))
 163     If RegEnumKeyEx(kHandle, Index, ByVal Data, vLen, 0&, ByVal 0&, 0&, ByVal 0&) = 0 Then
 164         Data = Left$(Data, vLen)
 165         If Data = String$(255, Chr$(0)) Then Data = ""
 166         EnumKey = Data
 167     End If
 168     RegCloseKey kHandle
 169 End If
 170 End Function
 171 Sub MultiStringToArray(MultiString As String, ByRef StrArray() As String)
 172 Dim cNum As Long, cNum2 As Long
 173 ReDim StrArray(0)
 174 For cNum = 1 To Len(MultiString)
 175     cNum2 = InStr(cNum, MultiString, Chr(0))
 176     If cNum2 = 0 Then cNum2 = Len(MultiString) + 1
 177     ReDim Preserve StrArray(UBound(StrArray) + 1)
 178     StrArray(UBound(StrArray)) = Mid$(MultiString, cNum, cNum2 - cNum)
 179     cNum = cNum2
 180 Next cNum
 181 End Sub
 182 Sub ArrayToMultiString(StrArray() As String, ByRef MultiString As String)
 183 Dim sNum As Long
 184 MultiString = ""
 185 For sNum = 1 To UBound(StrArray)
 186     MultiString = MultiString + StrArray(sNum) + Chr$(0)
 187 Next sNum
 188 End Sub
 189 Sub NewKey(ByVal Path As String, Optional Default, Optional vType)
 190 Attribute NewKey.VB_Description = "Creates a new key in the registry."
 191 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Temp As Long, Setg As String, NumData As Long
 192 If Right$(Path, 1) <> "\" Then Path = Path + "\"
 193 ConvertValueName Path, hKey, Key, ValueName
 194 ValueName = ""
 195 If RegCreateKeyEx(hKey, Key, 0&, 0&, REG_OPTION_NON_VOLATILE, KEY_CREATE_SUB_KEY Or KEY_SET_VALUE, ByVal 0&, kHandle, Temp) = 0 Then
 196     If Not IsError(Default) Then
 197         If IsError(vType) Then vType = REG_SZ
 198         If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then
 199             NumData = Default
 200             RegSetValueEx kHandle, ValueName, 0&, vType, NumData, 4
 201         Else
 202             Setg = Default
 203             If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then _
 204                 Setg = Setg + Chr$(0)
 205             RegSetValueEx kHandle, ValueName, 0&, vType, ByVal Setg, Len(Setg)
 206         End If
 207     End If
 208     RegCloseKey kHandle
 209 End If
 210 End Sub
 211 Sub SetReg(Path As String, NewValue, Optional vType)
 212 Attribute SetReg.VB_Description = "Writes a value to the registry."
 213 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Setg As String, NumData As Long
 214 ConvertValueName Path, hKey, Key, ValueName
 215 If RegOpenKeyEx(hKey, Key, 0&, KEY_SET_VALUE, kHandle) = 0 Then
 216     If IsError(vType) Then vType = REG_SZ
 217     If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then
 218         NumData = NewValue
 219         RegSetValueEx kHandle, ValueName, 0&, vType, NumData, 4
 220     Else
 221         Setg = NewValue
 222         If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then _
 223             Setg = Setg + Chr$(0)
 224         RegSetValueEx kHandle, ValueName, 0&, vType, ByVal Setg, Len(Setg)
 225     End If
 226     RegCloseKey kHandle
 227 End If
 228 End Sub
 229 Sub DelReg(Path As String)
 230 Attribute DelReg.VB_Description = "Deletes a value from the registry."
 231 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String
 232 ConvertValueName Path, hKey, Key, ValueName
 233 If RegOpenKeyEx(hKey, Key, 0&, KEY_SET_VALUE, kHandle) = 0 Then
 234     RegDeleteValue kHandle, ValueName
 235     RegCloseKey kHandle
 236 End If
 237 End Sub
 238 Sub DelKey(ByVal Path As String)
 239 Attribute DelKey.VB_Description = "Deletes a key from the registry."
 240 Dim hKey As Long, Key As String, Data As String
 241 If Right$(Path, 1) <> "\" Then Path = Path + "\"
 242 ConvertValueName Path, hKey, Key, Data
 243 RegDeleteKey hKey, Key
 244 End Sub