Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" 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 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
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
Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long, lPredefinedKey As Long)
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0,
KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Sub
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType,
sValue, Len(sValue))
Case REG_DWORD, REG_BINARY
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&,
lType, lValue, 4)
End Select
End Function
Private Sub Form_Load()
'取得windows目录
Dim Path As String, strSave As String
strSave = String(50, Chr$(0))
Path = Left$(strSave, GetWindowsDirectory(strSave, Len(strSave)))
'转换图片并保存到Windows目录下面
Image1.Picture = LoadPicture(App.Path & "\MyFlower.Jpg")
SavePicture Image1, Path & "\MyFlower.bmp"
Dim aa As String
'写入注册表
'设定居中
SetKeyValue "Control Panel\desktop", "TileWallpaper",
"0", REG_SZ, HKEY_CURRENT_USER
'设定平铺
' SetKeyValue "Control Panel\desktop",
"TileWallpaper", "1", REG_SZ, HKEY_CURRENT_USER
'更换墙纸
aa = Path & "\MyFlower.bmp"
ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, aa, 0)
'在注册表中记录图片位置
SetKeyValue "Control Panel\desktop", "Wallpaper", aa,
REG_SZ, HKEY_CURRENT_USER
End Sub |
