[VB] Registry

[Evan]

Option Explicit
 
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
 
    ' Reg Key Security Options...
    Const READ_CONTROL = &H20000
    Const KEY_QUERY_VALUE = &H1
    Const KEY_SET_VALUE = &H2
    Const KEY_CREATE_SUB_KEY = &H4
    Const KEY_ENUMERATE_SUB_KEYS = &H8
    Const KEY_NOTIFY = &H10
    Const KEY_CREATE_LINK = &H20
 
    ' Reg Key ROOT Types...
    Const HKEY_LOCAL_MACHINE = &H80000002
    Const ERROR_SUCCESS = 0
    Const REG_SZ = 1                         ' Unicode nul terminated string
    Const REG_DWORD = 4                      ' 32-bit number
 
    Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
    Const gREGVALSYSINFOLOC = "MSINFO"
    Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
    Const gREGVALSYSINFO = "PATH"
 
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 RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
 
 
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
 
 
    Const HKEY_DYN_DATA = &H80000006
    Const REG_BINARY = 3
    Const REG_DWORD_BIG_ENDIAN = 5
    Const REG_DWORD_LITTLE_ENDIAN = 4
    Const REG_EXPAND_SZ = 2
    Const REG_LINK = 6
    Const REG_MULTI_SZ = 7
    Const REG_NONE = 0
    Const REG_RESOURCE_LIST = 8
 
 
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 GetString(ByVal hKey As Long, ByVal strpath As String, ByVal strvalue As String)
 Dim keyhand&
 Dim datatype&, r#
 r = RegOpenKey(hKey, strpath, keyhand&)
 GetString = RegQueryStringValue(keyhand&, strvalue)
 r = 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 savestring(ByVal hKey As Long, ByVal strpath As String, ByVal strvalue As String, ByVal strdata As String)
 Dim keyhand&, r#
 r = RegCreateKey(hKey, strpath, keyhand&)
 r = RegSetValueEx(keyhand&, strvalue, 0, REG_SZ, ByVal strdata, Len(strdata))
 r = RegCloseKey(keyhand&)
End Sub
 
Public Sub Delstring(ByVal hKey As Long, ByVal strpath As String, ByVal sKey As String)
 Dim keyhand&, r#
 r = RegOpenKey(hKey, strpath, keyhand&)
 r = RegDeleteValue(keyhand&, sKey)
 r = RegCloseKey(keyhand&)
End Sub
 
Public Sub DeleteKey(ByVal hKey As Long, ByVal strpath As String, ByVal sKey As String)
 Dim keyhand&, r#
 r = RegOpenKey(hKey, strpath, keyhand&)
 r = RegDeleteKey(keyhand&, sKey)
 r = RegCloseKey(keyhand&)
End Sub
 
Public Sub SaveSet(ByVal AppName As String, ByVal Section As String, ByVal Key As Variant, ByVal Value As Variant)
    On Error Resume Next
    savestring HKEY_CURRENT_USER, "Software\" & App.CompanyName & "\" & AppName & "\" & Section, CStr(Key), CStr(Value)
End Sub
 
Public Function GetSet(ByVal AppName As String, ByVal Section As String, Key As Variant, Optional Default As Variant = "") As Variant
    Dim hKey As Long, subkey As String, stringbuffer As String
    Dim datatype As Long, slength As Long, retval As Long
    
    subkey = "Software\" & App.CompanyName & "\" & AppName & "\" & Section
    retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_READ, hKey)
    
    stringbuffer = Space(255)
    slength = 255
    
    retval = RegQueryValueEx(hKey, Key, 0, datatype, ByVal stringbuffer, slength)
    ' Only attempt to display the data if it is in fact a string.
    GetSet = CStr(Left(stringbuffer, slength - 1))
    GetSet = Replace(CStr(Left(stringbuffer, slength - 1)), " ", "")
    If Len(GetSet) > 0 Then
        GetSet = CStr(Left(stringbuffer, slength - 1))
    End If
        
    
    If GetSet = "" Then GetSet = Default
    ' Close the registry key.
    retval = RegCloseKey(hKey)
 
End Function
 
Public Function DelSet(ByVal AppName As String, ByVal Section As String, Key As Variant) As Variant
    On Error Resume Next
    Delstring HKEY_CURRENT_USER, "Software\" & App.CompanyName & "\" & AppName & "\" & Section, CStr(Key)
End Function
 
Public Function DelKey(ByVal AppName As String, ByVal Section As String, Key As Variant) As Variant
    On Error Resume Next
    DeleteKey HKEY_CURRENT_USER, "Software\" & App.CompanyName & "\" & AppName & "\" & Section, CStr(Key)
End Function