用VB更换桌面墙纸DIY

杜运庆

　　在客户运行您的应用程序的时候自动更换墙纸，显然是广告宣传的一个好机会。但无论是MSDN还是网络上的免费资源代码，更换墙纸几乎都是同一个API函数SystemParametersInfo和同一段代码，国外站点提供的免费代码也是如此。从VB4.0开始就这样。这段代码是：

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

Private Sub Form_Load()
　　ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER,
　　　　　　　　 0, "Path+BmpFile", 0)
End Sub

　　使用这个例程确实能够切换墙纸，但存在以下问题：

　　1、用鼠标右键点击桌面，会看到【背景】→【墙纸】里面的文件名是空的。

　　2、重新启动后桌面墙纸消失。

　　3、没告诉您怎么切换"居中"或"平铺"。

　　怎么解决这些问题呢？

　　1、Windows的墙纸必须以BMP格式的文件存放在Windows目录下面，如果您的图片不在该目录或不是BMP文件，那么就会出现第一个问题。因此必须把您的图片转换成BMP文件并复制到Windows目录下面。

　　2、要使重新启动后需要在注册表里面修改相应的键值，具体位置是 HKEY_CURRENT_USER\Control Panel\desktop中的Wallpaper键，让它的键值等于您的全路径文件名。

　　3、在更换墙纸以前首先设置是否"居中"，需要修改注册表中HKEY_CURRENT_USER\Control Panel\desktop中的TileWallpaper键，键值"0"表示"居中"，"1"表示"平铺"。




　　本例把一个JPG格式的图片成功地设置为墙纸，全部代码如下：

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

　　使用本例要注意：必须先设置是否"居中"，然后再更换墙纸。本例在Windows95+VB6下调试通过。

原文转自：http://www.ltesting.net