Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Read/Write permissions
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_ALL_ACCESS As Long = &HF003F
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_CREATE_LINK As Long = &H20
Private Const READ_CONTROL As Long = &H20000
Private Const WRITE_DAC As Long = &H40000
Private Const WRITE_OWNER As Long = &H80000
Private Const SYNCHRONIZE As Long = &H100000
Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Private Const STANDARD_RIGHTS_READ As Long = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE As Long = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE As Long = READ_CONTROL
Private Const KEY_READ As Long = STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY
Private Const KEY_WRITE As Long = STANDARD_RIGHTS_WRITE Or _
KEY_SET_VALUE Or _
KEY_CREATE_SUB_KEY
Private Const KEY_EXECUTE As Long = KEY_READ
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_USERS As Long = &H80000003
'Registration key types
Private Const REG_NONE As Long = &H0 'No value type
Private Const REG_SZ As Long = &H1 'null terminated string
Private Const REG_EXPAND_SZ As Long = &H2 'null terminated string
Private Const REG_BINARY As Long = &H3 'Free form binary
Private Const REG_DWORD As Long = &H4 '32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN As Long = &H4 '32-bit number (same as REG_DWORD)
Private Const REG_DWORD_BIG_ENDIAN As Long = &H5 '32-bit number
Private Const REG_LINK As Long = &H6 'Symbolic Link (Unicode)
Private Const REG_MULTI_SZ As Long = &H7 'Multiple Unicode strings
Private Const REG_RESOURCE_LIST As Long = &H8 'Resource list in the resource map
Private Const REG_FULL_RESOURCE_DESCRIPTOR As Long = &H9 'Resource list in the hardware description
Private Const REG_RESOURCE_REQUIREMENTS_LIST As Long = &HA
'Return codes from Registration functions
Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_BADDB As Long = 1009
Private Const ERROR_BADKEY As Long = 1010
Private Const ERROR_CANTOPEN As Long = 1011
Private Const ERROR_CANTREAD As Long = 1012
Private Const ERROR_CANTWRITE As Long = 1013
Private Const ERROR_OUTOFMEMORY As Long = 14
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_NO_MORE_ITEMS As Long = 259
'SendMessageTimeout values
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_SETTINGCHANGE As Long = &H1A
Private Const SPI_SETNONCLIENTMETRICS As Long = &H2A
Private Const SMTO_ABORTIFHUNG As Long = &H2
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult 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 lpValue As String, _
ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" _
(ByVal hKey As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" _
(ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long, _
ByVal fuFlags As Long, ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpszValueName As String, _
ByVal lpdwRes As Long, lpType As Long, _
lpData As Any, nSize As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
Call LockWindowUpdate(GetDesktopWindow())
ForceCacheRefresh
Call LockWindowUpdate(0)
End Sub
Private Sub ForceCacheRefresh()
Dim hKey As Long
Dim dwKeyType As Long
Dim dwDataType As Long
Dim dwDataSize As Long
Dim sKeyName As String
Dim sValue As String
Dim sDataRet As String
Dim tmp As Long
Dim sNewValue As String
Dim dwNewValue As Long
Dim success As Long
'HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\ShellIconSize
'HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\Shell Icon Size
'1. open HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics
'2. get the type of value and its size stored at value "Shell Icon Size"
'3. get value of "Shell Icon Size"
'4. change this value (i.e. decrement the value by one)
'5. write it back to the registry
'6. call SendMessageTimeout HWND_BROADCAST
'7. return "Shell Icon Size" to its original setting
'8. call SendMessageTimeout HWND_BROADCAST again
'9. close the key
''''''''''''''''''''''''
'Sample Debug output
''''''''''''''''''''''''
'RegKeyOpen = 468
'RegGetStringSize = 3
'RegGetStringValue = 32
'Changing to = 31
'Changing back to = 32
''''''''''''''''''''''''
'1. open key
dwKeyType = HKEY_CURRENT_USER
sKeyName = "Control Panel\Desktop\WindowMetrics"
sValue = "Shell Icon Size"
hKey = RegKeyOpen(HKEY_CURRENT_USER, sKeyName)
If hKey <> 0 Then
Debug.Print "RegKeyOpen = "; hKey
''''''''''''''''''''''''
'2. Determine the size and type of data to be read.
'In this case it should be a string (REG_SZ) value.
dwDataSize = RegGetStringSize(ByVal hKey, sValue, dwDataType)
Debug.Print "RegGetStringSize = "; dwDataSize
If dwDataSize > 0 Then
''''''''''''''''''''''''
'3. get the value for that key
sDataRet = RegGetStringValue(hKey, sValue, dwDataSize)
'if a value returned
If Len(sDataRet) > 0 Then
Debug.Print "RegGetStringValue = "; sDataRet
''''''''''''''''''''''''
'4, 5. convert sDataRet to a number and subtract 1,
'convert back to a string, define the size
'of the new string, and write it to the registry
tmp = CLng(sDataRet)
tmp = tmp - 1
sNewValue = CStr(tmp) & Chr$(0)
dwNewValue = Len(sNewValue)
Debug.Print "Changing to = "; sNewValue
If RegWriteStringValue(hKey, _
sValue, _
dwDataType, _
sNewValue) = ERROR_SUCCESS Then
''''''''''''''''''''''''
'6. because the registry was changed, broadcast
'the fact passing SPI_SETNONCLIENTMETRICS,
'with a timeout of 10000 milliseconds (10 seconds)
Call SendMessageTimeout(HWND_BROADCAST, _
WM_SETTINGCHANGE, _
SPI_SETNONCLIENTMETRICS, _
0&, SMTO_ABORTIFHUNG, _
10000&, success)
''''''''''''''''''''''''
'7. the desktop will have refreshed with the
'new (shrunken) icon size. Now restore things
'back to the correct settings by again writing
'to the registry and posing another message.
sDataRet = sDataRet & Chr$(0)
Debug.Print "Changing back to = "; sDataRet
Call RegWriteStringValue(hKey, _
sValue, _
dwDataType, _
sDataRet)
''''''''''''''''''''''''
'8. broadcast the change again
Call SendMessageTimeout(HWND_BROADCAST, _
WM_SETTINGCHANGE, _
SPI_SETNONCLIENTMETRICS, _
0&, SMTO_ABORTIFHUNG, _
10000&, success)
End If 'If RegWriteStringValue
End If 'If Len(sDataRet) > 0
End If 'If dwDataSize > 0
End If 'If hKey > 0
''''''''''''''''''''''''
'9. clean up
Call RegCloseKey(hKey)
End Sub
Private Function RegGetStringSize(ByVal hKey As Long, _
ByVal sValue As String, _
dwDataType As Long) As Long
Dim success As Long
Dim dwDataSize As Long
success = RegQueryValueEx(hKey, _
sValue, _
0&, _
dwDataType, _
ByVal 0&, _
dwDataSize)
If success = ERROR_SUCCESS Then
If dwDataType = REG_SZ Then
RegGetStringSize = dwDataSize
End If
End If
End Function
Private Function RegKeyOpen(dwKeyType As Long, sKeyPath As String) As Long
Dim hKey As Long
Dim dwOptions As Long
Dim SA As SECURITY_ATTRIBUTES
SA.nLength = Len(SA)
SA.bInheritHandle = False
dwOptions = 0&
If RegOpenKeyEx(dwKeyType, _
sKeyPath, _
dwOptions, _
KEY_ALL_ACCESS, _
hKey) = ERROR_SUCCESS Then
RegKeyOpen = hKey
End If
End Function
Private Function RegGetStringValue(ByVal hKey As Long, _
ByVal sValue As String, _
dwDataSize As Long) As String
Dim sDataRet As String
Dim dwDataRet As Long
Dim success As Long
Dim pos As Long
'get the value of the passed key
sDataRet = Space$(dwDataSize)
dwDataRet = Len(sDataRet)
success = RegQueryValueEx(hKey, _
sValue, _
ByVal 0&, _
dwDataSize, _
ByVal sDataRet, _
dwDataRet)
If success = ERROR_SUCCESS Then
If dwDataRet > 0 Then
pos = InStr(sDataRet, Chr$(0))
RegGetStringValue = Left$(sDataRet, pos - 1)
End If
End If
End Function
Private Function RegWriteStringValue(hKey, _
sValue, _
dwDataType, _
sNewValue) As Long
Dim dwNewValueSize As Long
dwNewValueSize = Len(sNewValue)
If dwNewValueSize > 0 Then
RegWriteStringValue = RegSetValueEx(hKey, _
sValue, _
0&, _
dwDataType, _
ByVal sNewValue, _
dwNewValueSize)
End If
End Function
|
