Các chiêu thức trong lập trình Thay đổi hình nền cho Desktophome

Thay đổi hình nền cho Desktop home
Xuất xứ : www.caulacbovb.com
Binh khí sử dụng : Một CommandButton
Đoạn mã :
Option Explicit
‘ Các hằng số và hàm phục vụ cho việc thay đổi WallPaper
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_SENDWININICHANGE = &H2
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
‘Phục vụ cho việc ghi giá trị vào Registry
Public Enum REG_TOPLEVEL_KEYS
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
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
Private 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
Private Const REG_SZ = 1
Public Function ChangeWallPaper(ImageFile As String, Optional Tile As Boolean =

True, Optional Center As Boolean = True) As Boolean
Dim lRet As Long
On Error Resume Next
If Tile Then 'Kieu Tile
WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper",
"1"
Else 'Center or Stretch
WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper",
"0"
'Center
If Center Then WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop",
"WallpaperStyle", "0" _
Else: WriteStringToRegistry HKEY_CURRENT_USER, "Control Panel\desktop",
"TileWallpaper", "2" ' Stretch
End If
lRet = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ImageFile, SPIF_UPDATEINIFILE
Or SPIF_SENDWININICHANGE)
ChangeWallPaper = lRet <> 0
End Function
Private Function WriteStringToRegistry(Hkey As REG_TOPLEVEL_KEYS, strPath As
String, strValue As String, strdata As String) As Boolean
Dim bAns As Boolean
On Error GoTo ErrorHandler
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
If (r = 0) Then
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End If

WriteStringToRegistry = (r = 0)
Exit Function
ErrorHandler:
WriteStringToRegistry = False
MsgBox "Thay doi gia tri Registry khong thanh cong", , "Loi :"
End Function
Private Sub Command1_Click()
‘ Load file ảnh cần thiết
ChangeWallPaper "C:\Ben Tre.bmp" ‘Kiểu Tile
‘ChangeWallPaper "C:\Ben Tre.bmp", False ‘Kiểu Center
‘ChangeWallPaper "C:\Ben Tre.bmp", False, False ‘Kiểu Stretch
End Sub