Option Explicit
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
' STRING
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
' LONG
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Long, ByVal cbData As Long) As Long
' BYTE
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 Const m_HCU As Long = &H80000001 'LOCAL MACHINE
Private Const m_HLM As Long = &H80000002 'CURRENT USER
' REGISTRY VALUES
Public Enum regTypes
ValNull = 0
ValString = 1
ValXString = 2
ValBinary = 3
ValDWord = 4
ValDWordLE = 4
ValDWordBE = 5
ValLink = 6
ValMultiString = 7
ValResList = 8
End Enum
' CLICK TO OPEN VALUES
Public Enum enClickToOpen
ctoDouble = 1
ctoSingle = 0
End Enum
' Single or Double Click on Items
Public Property Let ClickToOpen(ByVal inNew As enClickToOpen)
Dim bArr() As Byte
If inNew = ctoDouble Then 'double click
bArr = Hex2ByteArr("2400000033a80000000000000000000000000000010000000d0000000000000000000000")
Save_Value m_HCU, "Software\Microsoft\Windows\CurrentVersion\Explorer", "ShellState", bArr, ValBinary
Else 'single click
bArr = Hex2ByteArr("2400000013a80100000000000000000000000000010000000d0000000000000002000000")
Save_Value m_HCU, "Software\Microsoft\Windows\CurrentVersion\Explorer", "ShellState", bArr, ValBinary
End If
End Property
' SAVE / UPDATE REGISTRY VALUE
Private Sub Save_Value(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, _
ByVal varData As Variant, ByVal ValType As regTypes)
Dim keyhand As Long
Dim lResult As Long
Dim ordType As Long
Dim c As Long
lResult = RegCreateKey(hKey, strPath, keyhand)
If lResult Then
'error
Else
Select Case ValType
' BINARY VALUE (BYTE ARRAY)
Case ValBinary
If (VarType(varData) = vbArray + vbByte) Then
Dim ab() As Byte
ab = varData
c = UBound(ab) - LBound(ab) + 1
lResult = RegSetValueExByte(keyhand, strValue, 0&, ValType, ab(0), c)
Else
'error
End If
' DWORD VALUE (INT/LONG)
Case ValDWord, ValDWordBE, ValDWordLE
If (VarType(varData) = vbInteger) Or (VarType(varData) = vbLong) Then
Dim i As Long
i = varData
ordType = ValDWord
lResult = RegSetValueExLong(keyhand, strValue, 0&, ordType, i, 4)
Else
'error
End If
' STRING VALUE
Case ValString, ValXString
Dim s As String, iPos As Long
s = varData
ordType = ValString
iPos = InStr(s, "%")
If iPos Then
If InStr(iPos + 2, s, "%") Then ordType = ValXString
End If
c = Len(s) + 1
s = s & vbNullChar
lResult = RegSetValueExString(keyhand, strValue, 0&, ordType, s, c)
Case Else
'error
End Select
If lResult Then
'error
End If
RegCloseKey keyhand
End If
End Sub
' HEX TO BYTE ARR - Joacim Andersson
Private Function Hex2ByteArr(ByVal sHex As String) As Byte()
Dim n As Long
Dim nCount As Long
Dim bArr() As Byte
'First of all, make sure the length of the hex string is even, if it is not then
'put a "0" at the beginning
nCount = Len(sHex)
If (nCount And 1) = 1 Then
sHex = "0" & sHex
nCount = nCount + 1
End If
'ReDim the Byte array
ReDim bArr(nCount \ 2 - 1) 'we subtract 1 since the array is zero based
For n = 1 To nCount Step 2
'Convert the hex numbers into decimal values and store them in the byte array
bArr((n - 1) \ 2) = CByte("&H" & Mid$(sHex, n, 2))
Next
'Return the array
Hex2ByteArr = bArr
End Function